We’ve fit models to multiple different functional groups, and want to compare their performance across different iterations,

Dependencies

User defined parameters

print(params)
## $readParams
## [1] TRUE
## 
## $reRunClimDat
## [1] FALSE
# set to true if want to run for a limited number of rows (i.e. for code testing)

reRunClimDat <- params$reRunClimDat
readParams <- params$readParams
library(tidyverse)
library(sf)
library(terra)
library(kableExtra)
library(knitr)
library(USA.state.boundaries)
library(tidyterra)
library(ggpubr)

Read in data

use data from dayMet sampled on a grid across CONUS

# Load Data ---------------------------------------------------------------
# data ready for modeling (that has been scaled)
modDat_1_s <- readRDS("./models/scaledModelInputData.rds")
  
# get the soil raster, which we'll use for rasterizing the imagery
soilRastTemp <- readRDS("../../../Data_processed/SoilsRaster.rds") %>% 
terra::unwrap()

# make a map of the predictions
test_rast <-  rast("../../../Data_raw/dayMet/rawMonthlyData/orders/70e0da02b9d2d6e8faa8c97d211f3546/Daymet_Monthly_V4R1/data/daymet_v4_prcp_monttl_na_1980.tif") %>% 
  terra::aggregate(fact = 12, fun = "mean")

# download map info for visualization
data(state_boundaries_wgs84) 

cropped_states <- suppressMessages(state_boundaries_wgs84 %>%
  dplyr::filter(NAME!="Hawaii") %>%
  dplyr::filter(NAME!="Alaska") %>%
  dplyr::filter(NAME!="Puerto Rico") %>%
  dplyr::filter(NAME!="American Samoa") %>%
  dplyr::filter(NAME!="Guam") %>%
  dplyr::filter(NAME!="Commonwealth of the Northern Mariana Islands") %>%
  dplyr::filter(NAME!="United States Virgin Islands") %>%
  sf::st_sf() %>%
  sf::st_transform(sf::st_crs(test_rast))) 
  #sf::st_crop(sf::st_bbox(modDat_1_sf)+c(-1,-1,1,1))

## add ecoregion boundaries (for our ecoregion level model)
regions <- sf::st_read(dsn = "../../../Data_raw/Level2Ecoregions/", layer = "NA_CEC_Eco_Level2") 
## Reading layer `NA_CEC_Eco_Level2' from data source 
##   `/Users/astears/Documents/Dropbox_static/Work/NAU_USGS_postdoc/cleanPED/PED_vegClimModels/Data_raw/Level2Ecoregions' 
##   using driver `ESRI Shapefile'
## Simple feature collection with 2261 features and 8 fields
## Geometry type: POLYGON
## Dimension:     XY
## Bounding box:  xmin: -4334052 ymin: -3313739 xmax: 3324076 ymax: 4267265
## Projected CRS: Sphere_ARC_INFO_Lambert_Azimuthal_Equal_Area
regions <- regions %>% 
  st_transform(crs = st_crs(test_rast)) %>% 
  st_make_valid() 
ecoregionLU <- data.frame("NA_L1NAME" = sort(unique(regions$NA_L1NAME)), 
                        "newRegion" = c(NA, "Forest", "dryShrubGrass", 
                                        "dryShrubGrass", "Forest", "dryShrubGrass",
                                       "dryShrubGrass", "Forest", "Forest", 
                                       "dryShrubGrass", "Forest", "Forest", 
                                       "Forest", "Forest", "dryShrubGrass", 
                                       NA
                                        ))
goodRegions <- regions %>% 
  left_join(ecoregionLU)
mapRegions <- goodRegions %>% 
  filter(!is.na(newRegion)) %>% 
  group_by(newRegion) %>% 
  summarise(geometry = sf::st_union(geometry)) %>% 
  ungroup() %>% 
  st_simplify(dTolerance = 1000)
## function to get model statements
getModelStatement <- function(coefficientTable, # name of the d.f that has model coefficients
                  modelName, # name of the column in the coefficient table that has the parameters of interest
                  responseVar # name of the response variable
                  ) {
  ##
  # coefficientTable <- grassShrub_totalHerb_trimAnoms
  # modelName <- "coefficientValue_bestLambda"
  # responseVar <- "TotalHerbaceousCover"
  ##
  temp <- coefficientTable[,c("coefficientName", modelName)] %>% 
    drop_na()
  rownames(temp) <- temp$coefficientName
  temp[,modelName] <- round(temp[,modelName], 9)
  
  # print out coefficients w/ coefficient names
tempNames <- paste0(
  apply(temp, MARGIN = 1, FUN = function(x) {
    if (x["coefficientName"] == "(Intercept)") {
      paste0(x[modelName])
    } else {  
      paste0(x[modelName], "*", x["coefficientName"])
    }
    }
  ),
  collapse = " + "
)

# print the unscaled model statement
  unscaledModelName <- paste0(responseVar, "~ exp(", tempNames, ") - 2")
  
  # now add in the scale parameters
tempNames <- str_replace_all(tempNames, pattern = "annWetDegDays_anom", 
                         replacement = paste0("((annWetDegDays_anom - ", 
                                              round(scaleParams$annWetDegDays_anom_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$annWetDegDays_anom_s$`scaled:scale`,9), ")"))

tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr_anom", 
                         replacement = paste0("((prcpTempCorr_anom - ", 
                                              round(scaleParams$prcpTempCorr_anom_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcpTempCorr_anom_s$`scaled:scale`,9), ")"))


tempNames <- str_replace_all(tempNames, pattern = "prcp_seasonality_anom", 
                         replacement = paste0("((prcp_seasonality_anom - ", 
                                              round(scaleParams$prcp_seasonality_anom_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcp_seasonality_anom_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "annWatDef_anom", 
                         replacement = paste0("((annWatDef_anom - ", 
                                              round(scaleParams$annWatDef_anom_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$annWatDef_anom_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "isothermality_anom", 
                         replacement = paste0("((isothermality_anom - ", 
                                              round(scaleParams$isothermality_anom_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$isothermality_anom_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "prcp_anom", 
                         replacement = paste0("((prcp_anom - ", 
                                              round(scaleParams$prcp_anom_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcp_anom_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "prcp ", 
                         replacement = paste0("((prcp - ", 
                                              round(scaleParams$prcp_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcp_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "prcp\\^", 
                         replacement = paste0("((prcp - ", 
                                              round(scaleParams$prcp_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcp_s$`scaled:scale`,9), ")^"))

tempNames <- str_replace_all(tempNames, pattern = "prcp:", 
                         replacement = paste0("((prcp - ", 
                                              round(scaleParams$prcp_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcp_s$`scaled:scale`,9), "):"))

tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr ", 
                         replacement = paste0("((prcpTempCorr - ", 
                                              round(scaleParams$prcpTempCorr_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcpTempCorr_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr\\^", 
                         replacement = paste0("((prcpTempCorr - ", 
                                              round(scaleParams$prcpTempCorr_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcpTempCorr_s$`scaled:scale`,9), ")^"))

tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr:", 
                         replacement = paste0("((prcpTempCorr - ", 
                                              round(scaleParams$prcpTempCorr_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcpTempCorr_s$`scaled:scale`,9), "):"))

tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr\\)", 
                         replacement = paste0("((prcpTempCorr - ", 
                                              round(scaleParams$prcpTempCorr_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcpTempCorr_s$`scaled:scale`,9), "))"))

tempNames <- str_replace_all(tempNames, pattern = "prcpTempCorr$", 
                         replacement = paste0("((prcpTempCorr - ", 
                                              round(scaleParams$prcpTempCorr_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcpTempCorr_s$`scaled:scale`,9), ")"))

tempNames <- str_replace_all(tempNames, pattern = "isothermality ", 
                         replacement = paste0("((isothermality - ", 
                                              round(scaleParams$isothermality_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$isothermality_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "isothermality\\^", 
                         replacement = paste0("((isothermality - ", 
                                              round(scaleParams$isothermality_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$isothermality_s$`scaled:scale`,9), ")^"))

tempNames <- str_replace_all(tempNames, pattern = "isothermality:", 
                         replacement = paste0("((isothermality - ", 
                                              round(scaleParams$isothermality_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$isothermality_s$`scaled:scale`,9), "):"))

tempNames <- str_replace_all(tempNames, pattern = "sand", 
                         replacement = paste0("((sand - ", 
                                              round(scaleParams$sand_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$sand_s$`scaled:scale`,9), ")"))

tempNames <- str_replace_all(tempNames, pattern = "coarse", 
                         replacement = paste0("((coarse - ", 
                                              round(scaleParams$coarse_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$coarse_s$`scaled:scale`,9), ")"))

tempNames <- str_replace_all(tempNames, pattern = "AWHC", 
                         replacement = paste0("((AWHC - ", 
                                              round(scaleParams$AWHC_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$AWHC_s$`scaled:scale`,9), ")"))

tempNames <- str_replace_all(tempNames, pattern = "carbon", 
                         replacement = paste0("((carbon - ", 
                                              round(scaleParams$carbon_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$carbon_s$`scaled:scale`,9), ")"))

tempNames <- str_replace_all(tempNames, pattern = "clay", 
                         replacement = paste0("((clay - ", 
                                              round(scaleParams$clay_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$clay_s$`scaled:scale`,9), ")"))

tempNames <- str_replace_all(tempNames, pattern = "annWatDef ", 
                         replacement = paste0("((annWatDef - ", 
                                              round(scaleParams$annWatDef_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$annWatDef_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "annWatDef:", 
                         replacement = paste0("((annWatDef - ", 
                                              round(scaleParams$annWatDef_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$annWatDef_s$`scaled:scale`,9), "):"))

tempNames <- str_replace_all(tempNames, pattern = "prcp_seasonality ", 
                         replacement = paste0("((prcp_seasonality - ", 
                                              round(scaleParams$prcp_seasonality_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcp_seasonality_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "prcp_seasonality:", 
                         replacement = paste0("((prcp_seasonality - ", 
                                              round(scaleParams$prcp_seasonality_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcp_seasonality_s$`scaled:scale`,9), "):"))

tempNames <- str_replace_all(tempNames, pattern = "prcp_seasonality\\^", 
                         replacement = paste0("((prcp_seasonality - ", 
                                              round(scaleParams$prcp_seasonality_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcp_seasonality_s$`scaled:scale`,9), ")^"))

tempNames <- str_replace_all(tempNames, pattern = "tmean ", 
                         replacement = paste0("((tmean - ", 
                                              round(scaleParams$tmean_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$tmean_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "tmean:", 
                         replacement = paste0("((tmean - ", 
                                              round(scaleParams$tmean_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$tmean_s$`scaled:scale`,9), "):"))

tempNames <- str_replace_all(tempNames, pattern = "tmean$", 
                         replacement = paste0("((tmean - ", 
                                              round(scaleParams$tmean_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$tmean_s$`scaled:scale`,9), ")"))

tempNames <- str_replace_all(tempNames, pattern = "tmean\\^", 
                         replacement = paste0("((tmean - ", 
                                              round(scaleParams$tmean_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$tmean_s$`scaled:scale`,9), ")^"))

tempNames <- str_replace_all(tempNames, pattern = "annWetDegDays ", 
                         replacement = paste0("((annWetDegDays - ", 
                                              round(scaleParams$annWetDegDays_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$annWetDegDays_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "annWetDegDays:", 
                         replacement = paste0("((annWetDegDays - ", 
                                              round(scaleParams$annWetDegDays_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$annWetDegDays_s$`scaled:scale`,9), "):"))

tempNames <- str_replace_all(tempNames, pattern = "prcp_dry ", 
                         replacement = paste0("((prcp_dry - ", 
                                              round(scaleParams$prcp_dry_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcp_dry_s$`scaled:scale`,9), ") "))

tempNames <- str_replace_all(tempNames, pattern = "prcp_dry:", 
                         replacement = paste0("((prcp_dry - ", 
                                              round(scaleParams$prcp_dry_s$`scaled:center`,9), ") / ", 
                                              round(scaleParams$prcp_dry_s$`scaled:scale`,9), "):"))


## print scaled model statement

scaledModelName <- paste0(responseVar, "~ exp(", tempNames, ") - 2")
  
return(list("scaledInputVars_ModelStatement" = unscaledModelName, 
            "unscaledInputVars_scaledModelStatement" = scaledModelName))
}


 ### make predictions
makePredictions <- function(predictionDF, modelObject) {
  ##
  # predictionDF <- climDatPred
  # modelObject <- bestLambdaMod_grassShrub_totalHerb
  # ##
  
  # pretend to scale the input variables so the model object can predict accurately
  predictionDF <- predictionDF %>% 
  mutate(across(all_of(prednames), base::scale,scale = FALSE, center = FALSE)) 
  
  # modelPredictions
  modelPreds <- predict(object = modelObject, newdata = predictionDF, type = "response")
  # add predictions back into the input data.frame
  predictionDF <- predictionDF %>% 
    cbind(modelPreds)
  
  # truncate all predictions to max out at 100 
  #predictionDF[predictionDF$modelPreds>100 & !is.na(predictionDF$modelPreds),"modelPreds"] <- 100
predictionDF[predictionDF$modelPreds < 0 & !is.na(predictionDF$modelPreds),"modelPreds"] <- 0

  # print predicted data
 return(predictionDF)
}

Compare model performance

  • read in model specifications for each model
filePath <- c("")
# read in model specifications
# # no reduction of anomalies 
# grassShrub_totalHerb <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
# grassShrub_totalTree <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_TotalTreeCover_removeAnomaliesTRUE.rds")
# #grassShrub_shrub <- readRDS("./models/modelCoefficients_shrubGrass_ShrubCover.rds")
# #grassShrub_bareGround <- readRDS("./models/modelCoefficients_shrubGrass_BareGroundCover.rds")
# forest_totalHerb <- readRDS("./models/modelCoefficients_trimAnom_forest_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
# forest_totalTree <- readRDS("./models/modelCoefficients_trimAnom_forest_TotalTreeCover_removeAnomaliesTRUE.rds")
# #forest_shrub <- readRDS("./models/modelCoefficients_forest_ShrubCover.rds")
# #forest_bareGround <- readRDS("./models/modelCoefficients_forest_BareGroundCover.rds")
# CONUS_bareGround <- readRDS("./models/modelCoefficients_trimAnom_CONUS_BareGroundCover_removeAnomaliesFALSE.rds")
# CONUS_shrub <- readRDS("./models/modelCoefficients_trimAnom_CONUS_ShrubCover_removeAnomaliesFALSE.rds")

# with reduction of anomalies 
  grassShrub_totalHerb_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
grassShrub_totalTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_TotalTreeCover_removeAnomaliesTRUE.rds")
#grassShrub_shrub_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_ShrubCover.rds")
#grassShrub_bareGround_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_BareGroundCover.rds")
forest_totalHerb_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
forest_totalTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_TotalTreeCover_removeAnomaliesTRUE.rds")
#forest_shrub_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_ShrubCover.rds")
#forest_bareGround_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_BareGroundCover.rds")
CONUS_bareGround_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_BareGroundCover_removeAnomaliesFALSE.rds")
CONUS_shrub_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_ShrubCover_removeAnomaliesFALSE.rds")
CONUS_c3_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_C3GramCover_prop_removeAnomaliesFALSE.rds")
CONUS_c4_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_C4GramCover_prop_removeAnomaliesFALSE.rds")
CONUS_forb_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_ForbCover_prop_removeAnomaliesFALSE.rds")
CONUS_broadLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
  CONUS_needleLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_CONUS_ConifTreeCover_prop_removeAnomaliesFALSE.rds")

forest_broadLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
forest_needleLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_forest_ConifTreeCover_prop_removeAnomaliesFALSE.rds")
grassShrub_broadLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
grassShrub_needleLeavedTree_trimAnoms <- readRDS("./models/modelCoefficients_trimAnom_shrubGrass_ConifTreeCover_prop_removeAnomaliesFALSE.rds")

# read in model metrics# read in model metrics# read in model metrics
# # no reduction of anomalies 
# modMetrics_grassShrub_totalHerb <- readRDS("./models/modelMetrics_shrubGrass_TotalHerbaceousCover.rds")
# modMetrics_grassShrub_totalTree <- readRDS("./models/modelMetrics_shrubGrass_TotalTreeCover.rds")
# #modMetrics_grassShrub_shrub <- readRDS("./models/modelMetrics_shrubGrass_ShrubCover.rds")
# #modMetrics_grassShrub_bareGround <- readRDS("./models/modelMetrics_shrubGrass_BareGroundCover.rds")
# modMetrics_forest_totalHerb <- readRDS("./models/modelMetrics_forest_TotalHerbaceousCover.rds")
# modMetrics_forest_totalTree <- readRDS("./models/modelMetrics_forest_TotalTreeCover.rds")
# #modMetrics_forest_shrub <- readRDS("./models/modelMetrics_forest_ShrubCover.rds")
# #modMetrics_forest_bareGround <- readRDS("./models/modelMetrics_forest_BareGroundCover.rds")
# modMetrics_CONUS_bareGround <- readRDS("./models/modelMetrics_CONUS_BareGroundCover.rds")
# modMetrics_CONUS_shrub <- readRDS("./models/modelMetrics_CONUS_ShrubCover.rds")

# with reduction of anomalies 
modMetrics_grassShrub_totalHerb_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
modMetrics_grassShrub_totalTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_TotalTreeCover_removeAnomaliesTRUE.rds")
#modMetrics_grassShrub_shrub_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_ShrubCover.rds")
#modMetrics_grassShrub_bareGround_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_BareGroundCover.rds")
modMetrics_forest_totalHerb_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_TotalHerbaceousCover_removeAnomaliesFALSE.rds")
modMetrics_forest_totalTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_TotalTreeCover_removeAnomaliesTRUE.rds")
#modMetrics_forest_shrub_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_ShrubCover.rds")
#modMetrics_forest_bareGround_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_BareGroundCover.rds")
modMetrics_CONUS_bareGround_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_BareGroundCover_removeAnomaliesFALSE.rds")
modMetrics_CONUS_shrub_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_ShrubCover_removeAnomaliesFALSE.rds")
modMetrics_CONUS_C3_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_C3GramCover_prop_removeAnomaliesFALSE.rds")
modMetrics_CONUS_C4_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_C4GramCover_prop_removeAnomaliesFALSE.rds")
modMetrics_CONUS_forb_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_ForbCover_prop_removeAnomaliesFALSE.rds")
modMetrics_CONUS_broadLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
modMetrics_CONUS_needleLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_CONUS_ConifTreeCover_prop_removeAnomaliesFALSE.rds")
modMetrics_forest_broadLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
modMetrics_forest_needleLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_forest_ConifTreeCover_prop_removeAnomaliesFALSE.rds")
modMetrics_grassShrub_broadLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_AngioTreeCover_prop_removeAnomaliesFALSE.rds")
modMetrics_grassShrub_needleLeavedTree_trimAnom <- readRDS("./models/modelMetrics_trimAnom_shrubGrass_ConifTreeCover_prop_removeAnomaliesFALSE.rds")

Now, show the different model performance metrics for each group (for now, only showing models that remove anomalies whose corresponding weather variables aren’t present in the LASSO model)

# grass shrub
knitr::kable(format = "html", modMetrics_grassShrub_totalHerb_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "grass/shrub - Total Herbaceous Cover"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
grass/shrub - Total Herbaceous Cover
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.203 0.207 0.218
bias: mean(obs-pred.) 3.06e-13 -2.32e-15 -6.49e-10
Total number of coefficients 28 17 7
Number of unique coefficients 12 8 5
Number of unique climate coefficients 5 5 2
Number of unique weather coefficients 3 0 0
Number of unique soils coefficients 4 3 3
knitr::kable(format = "html", modMetrics_grassShrub_totalTree_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "grass/shrub - Total Tree Cover"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
grass/shrub - Total Tree Cover
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.134 0.144 0.144
bias: mean(obs-pred.) -1.98e-11 5.52e-13 5.52e-13
Total number of coefficients 5 0 0
Number of unique coefficients 4 0 0
Number of unique climate coefficients 2 0 0
Number of unique weather coefficients 0 0 0
Number of unique soils coefficients 2 0 0
#forest
knitr::kable(format = "html", modMetrics_forest_totalHerb_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "forest - Total Herbaceous Cover"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
forest - Total Herbaceous Cover
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.22 0.238 0.238
bias: mean(obs-pred.) -1.02e-15 -5.31e-11 -5.31e-11
Total number of coefficients 18 0 0
Number of unique coefficients 12 0 0
Number of unique climate coefficients 5 0 0
Number of unique weather coefficients 2 0 0
Number of unique soils coefficients 5 0 0
knitr::kable(format = "html", modMetrics_forest_totalTree_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "forest - Total Tree Cover"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
forest - Total Tree Cover
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.253 0.253 0.264
bias: mean(obs-pred.) -7.56e-11 -3.98e-13 1.5e-15
Total number of coefficients 14 13 3
Number of unique coefficients 10 10 3
Number of unique climate coefficients 5 5 3
Number of unique weather coefficients 0 0 0
Number of unique soils coefficients 5 5 0
#CONUS

knitr::kable(format = "html", modMetrics_CONUS_shrub_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "CONUS - shrub cover"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
CONUS - shrub cover
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.142 0.156 0.156
bias: mean(obs-pred.) -3.01e-12 1.26e-12 1.26e-12
Total number of coefficients 15 0 0
Number of unique coefficients 11 0 0
Number of unique climate coefficients 6 0 0
Number of unique weather coefficients 2 0 0
Number of unique soils coefficients 3 0 0
knitr::kable(format = "html", modMetrics_CONUS_bareGround_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "CONUS - bare ground"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
CONUS - bare ground
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.131 0.13 0.133
bias: mean(obs-pred.) -1.98e-16 -3.25e-10 -6.07e-12
Total number of coefficients 40 23 17
Number of unique coefficients 13 9 10
Number of unique climate coefficients 6 6 5
Number of unique weather coefficients 4 0 2
Number of unique soils coefficients 3 3 3
knitr::kable(format = "html", modMetrics_CONUS_C3_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "CONUS - proportion of total herb. that is C3 "
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
CONUS - proportion of total herb. that is C3
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.229 0.231 0.231
bias: mean(obs-pred.) -3.3e-11 9.18e-16 -2.48e-11
Total number of coefficients 28 22 17
Number of unique coefficients 13 9 13
Number of unique climate coefficients 6 6 6
Number of unique weather coefficients 4 0 4
Number of unique soils coefficients 3 3 3
knitr::kable(format = "html", modMetrics_CONUS_C4_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "CONUS - proportion of total herb. that is C4 "
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
CONUS - proportion of total herb. that is C4
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.183 0.174 0.183
bias: mean(obs-pred.) -1.88e-13 -4.3e-15 -1.81e-15
Total number of coefficients 5 17 4
Number of unique coefficients 3 8 3
Number of unique climate coefficients 3 6 3
Number of unique weather coefficients 0 0 0
Number of unique soils coefficients 0 2 0
knitr::kable(format = "html", modMetrics_CONUS_forb_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "CONUS - proportion of total herb. that is forb "
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
CONUS - proportion of total herb. that is forb
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.228 0.23 0.229
bias: mean(obs-pred.) 4.11e-12 1.05e-12 3.24e-13
Total number of coefficients 66 27 40
Number of unique coefficients 13 9 13
Number of unique climate coefficients 6 6 6
Number of unique weather coefficients 4 0 4
Number of unique soils coefficients 3 3 3
knitr::kable(format = "html", modMetrics_CONUS_broadLeavedTree_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "CONUS - proportion of total tree that is broad-leaved"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
CONUS - proportion of total tree that is broad-leaved
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.308 0.3 0.312
bias: mean(obs-pred.) 1.17e-14 -4.58e-12 1.92e-15
Total number of coefficients 9 15 8
Number of unique coefficients 6 9 6
Number of unique climate coefficients 5 6 5
Number of unique weather coefficients 0 0 0
Number of unique soils coefficients 1 3 1
knitr::kable(format = "html", modMetrics_CONUS_needleLeavedTree_trimAnom,
             col.names = c("best Lambda model", "1/2 se lambda model", "1 se lambda model"),
              caption = "CONUS - proportion of total tree that is needle-leaved"
) %>%
kable_styling(bootstrap_options = c("striped", "hover", "condensed"))
CONUS - proportion of total tree that is needle-leaved
best Lambda model 1/2 se lambda model 1 se lambda model
RMSE 0.272 0.278 0.293
bias: mean(obs-pred.) 2.45e-13 5.34e-14 1.22e-15
Total number of coefficients 10 8 2
Number of unique coefficients 7 6 2
Number of unique climate coefficients 5 5 2
Number of unique weather coefficients 0 0 0
Number of unique soils coefficients 2 1 0

First, get the contemporary climate and weather data that we’ll use for predictions

Get climate data from dayMet for wall-to-wall predictions (arbitrarily chose 2016)

climDat_temp <- readRDS("/Users/astears/Documents/Dropbox_static/Work/NAU_USGS_postdoc/PED_vegClimModels/Data_processed/EcoRegion_climSoilData.rds")
# rename
climDat <- climDat_temp %>% 
  filter(year == 2016) %>% 
  dplyr::select(tmin_meanAnnAvg_CLIM:durationFrostFreeDays_meanAnnAvg_3yrAnom, NA_L1CODE, 
         NA_L1NAME, NA_L1KEY, newRegion, x, y, soilDepth:totalAvailableWaterHoldingCapacity) %>% 
rename("tmin" = tmin_meanAnnAvg_CLIM, 
     "tmax" = tmax_meanAnnAvg_CLIM, #1 
     "tmean" = tmean_meanAnnAvg_CLIM, 
     "prcp" = prcp_meanAnnTotal_CLIM, 
     "t_warm" = T_warmestMonth_meanAnnAvg_CLIM,
     "t_cold" = T_coldestMonth_meanAnnAvg_CLIM, 
     "prcp_wet" = precip_wettestMonth_meanAnnAvg_CLIM,
     "prcp_dry" = precip_driestMonth_meanAnnAvg_CLIM, 
     "prcp_seasonality" = precip_Seasonality_meanAnnAvg_CLIM, #2
     "prcpTempCorr" = PrecipTempCorr_meanAnnAvg_CLIM,  #3
     "abvFreezingMonth" = aboveFreezing_month_meanAnnAvg_CLIM, 
     "isothermality" = isothermality_meanAnnAvg_CLIM, #4
     "annWatDef" = annWaterDeficit_meanAnnAvg_CLIM, 
     "annWetDegDays" = annWetDegDays_meanAnnAvg_CLIM,
     "VPD_mean" = annVPD_mean_meanAnnAvg_CLIM, 
     "VPD_max" = annVPD_max_meanAnnAvg_CLIM, #5
     "VPD_min" = annVPD_min_meanAnnAvg_CLIM, #6
     "VPD_max_95" = annVPD_max_95percentile_CLIM, 
     "annWatDef_95" = annWaterDeficit_95percentile_CLIM, 
     "annWetDegDays_5" = annWetDegDays_5percentile_CLIM, 
     "frostFreeDays_5" = durationFrostFreeDays_5percentile_CLIM, 
     "frostFreeDays" = durationFrostFreeDays_meanAnnAvg_CLIM, 
     "soilDepth" = soilDepth, #7
     "clay" = surfaceClay_perc, 
     "sand" = avgSandPerc_acrossDepth, #8
     "coarse" = avgCoarsePerc_acrossDepth, #9
     "carbon" = avgOrganicCarbonPerc_0_3cm, #10
     "AWHC" = totalAvailableWaterHoldingCapacity,
     ## anomaly variables
     tmean_anom = tmean_meanAnnAvg_3yrAnom, #15
     tmin_anom = tmin_meanAnnAvg_3yrAnom, #16
     tmax_anom = tmax_meanAnnAvg_3yrAnom, #17
    prcp_anom = prcp_meanAnnTotal_3yrAnom, #18
      t_warm_anom = T_warmestMonth_meanAnnAvg_3yrAnom,  #19
     t_cold_anom = T_coldestMonth_meanAnnAvg_3yrAnom, #20
      prcp_wet_anom = precip_wettestMonth_meanAnnAvg_3yrAnom, #21
      precp_dry_anom = precip_driestMonth_meanAnnAvg_3yrAnom,  #22
    prcp_seasonality_anom = precip_Seasonality_meanAnnAvg_3yrAnom, #23 
     prcpTempCorr_anom = PrecipTempCorr_meanAnnAvg_3yrAnom, #24
      aboveFreezingMonth_anom = aboveFreezing_month_meanAnnAvg_3yrAnom, #25  
    isothermality_anom = isothermality_meanAnnAvg_3yrAnom, #26
       annWatDef_anom = annWaterDeficit_meanAnnAvg_3yrAnom, #27
     annWetDegDays_anom = annWetDegDays_meanAnnAvg_3yrAnom,  #28
      VPD_mean_anom = annVPD_mean_meanAnnAvg_3yrAnom, #29
      VPD_min_anom = annVPD_min_meanAnnAvg_3yrAnom,  #30
      VPD_max_anom = annVPD_max_meanAnnAvg_3yrAnom,  #31
     VPD_max_95_anom = annVPD_max_95percentile_3yrAnom, #32
      annWatDef_95_anom = annWaterDeficit_95percentile_3yrAnom, #33 
      annWetDegDays_5_anom = annWetDegDays_5percentile_3yrAnom ,  #34
    frostFreeDays_5_anom = durationFrostFreeDays_5percentile_3yrAnom, #35 
      frostFreeDays_anom = durationFrostFreeDays_meanAnnAvg_3yrAnom #36
  ) %>% 
  dplyr::select(-c(tmin_meanAnnAvg_3yr:Start_3yr))

rm(climDat_temp) 
gc()
##             used  (Mb) gc trigger   (Mb) limit (Mb)  max used   (Mb)
## Ncells   2368628 126.5    3885738  207.6         NA   3885738  207.6
## Vcells 115977238 884.9  842591009 6428.5      65536 979200140 7470.8

Get the scaling factors for the data used to fit the models (scaling is done to entire dataset, so only need to get once for all models), and apply those same scaling factors to the data we’ll predict with

# get the scaling factors 
scaleParams <- modDat_1_s %>% 
  filter(Year == 2016) %>% 
  dplyr::select(tmin_s:AWHC_s) %>% 
  reframe(across(all_of(names(.)), attributes)) 

# apply the scaling factors to the contemporary climate data 
namesToScale <- climDat %>% 
  dplyr::select(tmin:frostFreeDays, tmean_anom:frostFreeDays_anom, soilDepth:AWHC) %>% 
  names()

climDat_scaled <- map(namesToScale, .f = function(x) {
  x_new <- (climDat[,x] - scaleParams[,paste0(x, "_s")]$`scaled:center`)/scaleParams[,paste0(x, "_s")]$`scaled:scale`
  return(data.frame(x_new))
}) %>% 
  purrr::list_cbind()
names(climDat_scaled) <- paste0(namesToScale, "_s")

climDatPred <- climDat %>% 
  dplyr::select(NA_L1CODE:y) %>% 
  cbind(climDat_scaled)
names(climDatPred)[7:56] <- str_remove(names(climDatPred)[7:56], pattern = "_s$")

rm(climDat_scaled) 
gc()
##             used   (Mb) gc trigger   (Mb) limit (Mb)  max used   (Mb)
## Ncells   2375774  126.9    3885738  207.6         NA   3885738  207.6
## Vcells 141123312 1076.7  674072808 5142.8      65536 979200140 7470.8
prednames_s <-  modDat_1_s %>%
  dplyr::select(tmin_s:AWHC_s) %>%
  names()
prednames <- str_replace(prednames_s, pattern = "_s$", replacement = "")


climDat_long <- climDatPred %>% 
  rename_with(.cols = any_of(c(prednames, "tmin", "tmax")), .fn = ~paste0(.x, "_s")) %>% 
  pivot_longer(cols = c(tmin_s:AWHC_s), names_to = "variableName", values_to = "values") %>% 
  mutate(source = "climDat") %>% 
  dplyr::select(x, y, variableName, values, source)
modDat_long <- modDat_1_s %>% 
  pivot_longer(cols = c(tmin_s:AWHC_s), names_to = "variableName", values_to = "values") %>% 
  mutate(source = "modDat") %>% 
  rename(x = x, y = y) %>% 
  dplyr::select(x, y, variableName, values, source)
allDat_long <- climDat_long %>% 
  rbind(modDat_long)

ggplot(allDat_long)  +
  facet_wrap(~variableName, scales = "free") +
  geom_density(aes(values, col = source)) +
  ggtitle("A figure to double-check that the climate data used for contemporary predictions is consistent with the data used for fitting")

Download modeled climate data from a given climate model

In this iteration, using data from the “BNU-ESM” model (what I call model #1) as the cool/wet(ish) option and the “IPSL-CM5A-MR (France)” (what I call model #1) model as the hot/dry option. For both models, we use data from the end of century w/ RCP 8.5

rm(allDat_long, climDat_long)
gc()
##             used   (Mb) gc trigger (Mb) limit (Mb)   max used    (Mb)
## Ncells   2643017  141.2    5241977  280         NA    5241977   280.0
## Vcells 407339009 3107.8 1297079514 9896      65536 2511826459 19163.8
if (reRunClimDat) {
  # MACA data from:  BNU-ESM model (cool/wet-ish)
## read in tmin data 
tmin_1a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmin_BNU-ESM_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>% 
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmin_1a) <- terra::time(tmin_1a)

tmin_1b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmin_BNU-ESM_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>% 
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmin_1b) <- terra::time(tmin_1b)

tmin_1 <- c(tmin_1a, tmin_1b)

# get points to subsample
points <- terra::crds(tmin_1)
pointsSamp <- points[sample(x = 1:nrow(points), size = 50000, replace = FALSE),] %>% 
  terra::vect() %>% 
  terra::set.crs(crs(test_rast))

# subsample tmin_1 points to a data frame
tmin_1Points <- tmin_1 %>% 
  terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
tmin_1Points_temp <- tmin_1Points %>% 
  #slice_sample(n = 10) %>% 
  pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "tmin_K") 

tmin_1Points_temp$Year <- as.numeric(str_split(tmin_1Points_temp$date, pattern = "-", simplify = TRUE)[,1])
tmin_1Points_temp$Month <- as.numeric(str_split(tmin_1Points_temp$date, pattern = "-", simplify = TRUE)[,2])

# convert temp in K to degrees C
tmin_1Points_temp$tmin_C <- tmin_1Points_temp$tmin_K - 273.15

# make into a wide format again
tmin_1Points <- tmin_1Points_temp %>% 
  pivot_wider(id_cols = c(x, y, Year), 
              names_from = Month, 
              values_from = tmin_C, 
              names_glue = "tmin_C_{Month}")

## read in tmax data 
tmax_1a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmax_BNU-ESM_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>% 
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmax_1a) <- terra::time(tmax_1a)

tmax_1b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmax_BNU-ESM_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>% 
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmax_1b) <- terra::time(tmax_1b)

tmax_1 <- c(tmax_1a, tmax_1b)

# subsample tmax points to a data frame
tmax_1Points <- tmax_1 %>% 
  terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
tmax_1Points_temp <- tmax_1Points %>% 
  #slice_sample(n = 10) %>% 
  pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "tmax_K") 

tmax_1Points_temp$Year <- as.numeric(str_split(tmax_1Points_temp$date, pattern = "-", simplify = TRUE)[,1])
tmax_1Points_temp$Month <- as.numeric(str_split(tmax_1Points_temp$date, pattern = "-", simplify = TRUE)[,2])

# convert temp in K to degrees C
tmax_1Points_temp$tmax_C <- tmax_1Points_temp$tmax_K - 273.15

# make into a wide format again
tmax_1Points <- tmax_1Points_temp %>% 
  pivot_wider(id_cols = c(x, y, Year), 
              names_from = Month, 
              values_from = tmax_C, 
              names_glue = "tmax_C_{Month}")

## read in precip data 
prcp_1a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_pr_BNU-ESM_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>%
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(prcp_1a) <- terra::time(prcp_1a)
prcp_1b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_pr_BNU-ESM_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>%
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(prcp_1b) <- terra::time(prcp_1b)

prcp_1 <- c(prcp_1a, prcp_1b)

# subsample tmax points to a data frame
prcp_1Points <- prcp_1 %>% 
  terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
prcp_1Points_temp <- prcp_1Points %>% 
  #slice_sample(n = 10) %>% 
  pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "prcp_mm") 

prcp_1Points_temp$Year <- as.numeric(str_split(prcp_1Points_temp$date, pattern = "-", simplify = TRUE)[,1])
prcp_1Points_temp$Month <- as.numeric(str_split(prcp_1Points_temp$date, pattern = "-", simplify = TRUE)[,2])

# make into a wide format again
prcp_1Points <- prcp_1Points_temp %>% 
  pivot_wider(id_cols = c(x, y, Year), 
              names_from = Month, 
              values_from = prcp_mm, 
              names_glue = "prcp_mm_{Month}")

## add all data frames together
climDat_monthly_1 <- tmin_1Points %>% 
  left_join(tmax_1Points, by = c("x", "y", "Year")) %>% 
  left_join(prcp_1Points, by = c("x", "y", "Year"))

# MACA data from:  IPSL-CM5A-MR (France) (warm/dry)
## read in tmin data 
tmin_2a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmin_IPSL-CM5A-MR_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>% 
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmin_2a) <- terra::time(tmin_2a)

tmin_2b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmin_IPSL-CM5A-MR_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>% 
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmin_2b) <- terra::time(tmin_2b)

tmin_2 <- c(tmin_2a, tmin_2b)

# get points to subsample
points <- terra::crds(tmin_2)
pointsSamp <- points[sample(x = 1:nrow(points), size = 50000, replace = FALSE),] %>% 
  terra::vect() %>% 
  terra::set.crs(crs(test_rast))

# subsample tmin_2 points to a data frame
tmin_2Points <- tmin_2 %>% 
  terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
tmin_2Points_temp <- tmin_2Points %>% 
  #slice_sample(n = 10) %>% 
  pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "tmin_K") 

tmin_2Points_temp$Year <- as.numeric(str_split(tmin_2Points_temp$date, pattern = "-", simplify = TRUE)[,1])
tmin_2Points_temp$Month <- as.numeric(str_split(tmin_2Points_temp$date, pattern = "-", simplify = TRUE)[,2])

# convert temp in K to degrees C
tmin_2Points_temp$tmin_C <- tmin_2Points_temp$tmin_K - 273.15

# make into a wide format again
tmin_2Points <- tmin_2Points_temp %>% 
  pivot_wider(id_cols = c(x, y, Year), 
              names_from = Month, 
              values_from = tmin_C, 
              names_glue = "tmin_C_{Month}")

## read in tmax data 
tmax_2a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmax_IPSL-CM5A-MR_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>% 
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmax_2a) <- terra::time(tmax_2a)

tmax_2b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_tasmax_IPSL-CM5A-MR_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>% 
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(tmax_2b) <- terra::time(tmax_2b)

tmax_2 <- c(tmax_2a, tmax_2b)

# subsample tmax points to a data frame
tmax_2Points <- tmax_2 %>% 
  terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
tmax_2Points_temp <- tmax_2Points %>% 
  #slice_sample(n = 10) %>% 
  pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "tmax_K") 

tmax_2Points_temp$Year <- as.numeric(str_split(tmax_2Points_temp$date, pattern = "-", simplify = TRUE)[,1])
tmax_2Points_temp$Month <- as.numeric(str_split(tmax_2Points_temp$date, pattern = "-", simplify = TRUE)[,2])

# convert temp in K to degrees C
tmax_2Points_temp$tmax_C <- tmax_2Points_temp$tmax_K - 273.15

# make into a wide format again
tmax_2Points <- tmax_2Points_temp %>% 
  pivot_wider(id_cols = c(x, y, Year), 
              names_from = Month, 
              values_from = tmax_C, 
              names_glue = "tmax_C_{Month}")

## read in precip data 
prcp_2a <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_pr_IPSL-CM5A-MR_r1i1p1_rcp85_2066_2085_CONUS_monthly.nc") %>%
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(prcp_2a) <- terra::time(prcp_2a)
prcp_2b <- rast("../../../Data_raw/macaClimateProjections/Data/macav2livneh_pr_IPSL-CM5A-MR_r1i1p1_rcp85_2086_2099_CONUS_monthly.nc") %>%
  terra::project(y = test_rast) # reproject to match the data used for model fitting
names(prcp_2b) <- terra::time(prcp_2b)

prcp_2 <- c(prcp_2a, prcp_2b)

# subsample tmax points to a data frame
prcp_2Points <- prcp_2 %>% 
  terra::extract(y = pointsSamp, xy = TRUE)
# get month and year data
prcp_2Points_temp <- prcp_2Points %>% 
  #slice_sample(n = 10) %>% 
  pivot_longer(cols = `2066-01-15`:`2099-12-15`, names_to = "date", values_to = "prcp_mm") 

prcp_2Points_temp$Year <- as.numeric(str_split(prcp_2Points_temp$date, pattern = "-", simplify = TRUE)[,1])
prcp_2Points_temp$Month <- as.numeric(str_split(prcp_2Points_temp$date, pattern = "-", simplify = TRUE)[,2])

# make into a wide format again
prcp_2Points <- prcp_2Points_temp %>% 
  pivot_wider(id_cols = c(x, y, Year), 
              names_from = Month, 
              values_from = prcp_mm, 
              names_glue = "prcp_mm_{Month}")

## add all data frames together
climDat_monthly_2 <- tmin_2Points %>% 
  left_join(tmax_2Points, by = c("x", "y", "Year")) %>% 
  left_join(prcp_2Points, by = c("x", "y", "Year"))
# Calculate climate means and weather anomalies for the first set of climate model data 
climVar_1 <- climDat_monthly_1 %>% 
  #slice(1:100) %>% 
  mutate(totalAnnPrecip = rowSums(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")]), # total annual precipitation in mm
         T_warmestMonth = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10",  "tmax_C_11",  "tmax_C_12")], max), # temperature of warmest month
         T_coldestMonth = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10",  "tmin_C_11",  "tmin_C_12")], min), # temperature of coldest month
         Tmin_annAvgOfMonthly = rowSums(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10",  "tmin_C_11",  "tmin_C_12")])/12,
         Tmax_annAvgOfMonthly = rowSums(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10",  "tmax_C_11",  "tmax_C_12")])/12,
         #meanAnnVp = rowMeans(.[28:39]), # annual mean vapor pressure
         precip_wettestMonth = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")],
                                        max), # precip of wettest month
         precip_driestMonth = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")], 
                                       min), # precip of driest month
         precip_Seasonality = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")],   # coefficient of variation (sd/mean) of precipitation
                                       .f = function(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12, ...) 
                                       {temp <- c(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12)
                                       sd(temp)/mean(temp)
                                       }
         ),
         PrecipTempCorr = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10",  "tmax_C_11",  "tmax_C_12",
                                       "prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")], #correlation of monthly temp and precip
                                   .f = function(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10,  tmax_C_11,  tmax_C_12,
                                                 prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12, ...) {
                                     cor(y = c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10,  tmax_C_11,  tmax_C_12), 
                                         x = c(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12))
                                   }),
         aboveFreezing_month = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10",  "tmin_C_11",  "tmin_C_12")], # month when temp gets above freezing (when tmin > 0 degrees C, so no freeze at night )
                                        .f = function(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12) {
                                          temp <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12)
                                          which(temp > 0)[1] # in degrees C
                                        }),
         lastAboveFreezing_month = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10",  "tmin_C_11",  "tmin_C_12")], # month when temp gets above freezing (when tmin > 0 degrees C, so no freeze at night )
                                        .f = function(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12) {
                                          temp <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12)
                                          temp2 <- which(temp > 0) # in degrees C
                                          if(length(temp2)>0) {
                                            return(max(temp2))
                                          } else {
                                              return(NA)
                                            }
                                        }),
         
         isothermality = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10",  "tmax_C_11",  "tmax_C_12",
                                      "tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10",  "tmin_C_11",  "tmin_C_12")], # isothermality
                                  .f = function(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10,  tmax_C_11,  tmax_C_12,
                                                tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12, ...) {
                                    tmins <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12)
                                    tmaxes <- c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10,  tmax_C_11,  tmax_C_12)
                                    tMaxMax <- max(c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10,  tmax_C_11,  tmax_C_12))
                                    tMinMin <- min(c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12))
                                    mean(tmaxes-tmins)/(tMaxMax-tMinMin) * 100
                                  }),
         
  ) %>% 
  mutate(
    # calculate the duration of frost-free days (in our case here, Frost-free
    # days = (doy of first day of the first month when tmin is >0) - (doy of
    # last day of the lost month when tmin >0))
    # first month when tmin is above freezing is "aboveFreezing_month" in the previous d.f.
    # last month when tmin is above freezing is "lastAboveFreezing_month" in the previous d.f.
    durationFrostFreeDays = 
      # DOY of last day of last frost-free month (just give the 30th, since it
      # probably isn't a bit deal if we use the 30th rather than the 31st in
      # months when there is a 31st)
      lubridate::yday(as.Date(paste0(lastAboveFreezing_month, "/30/2024"), 
                              format = "%m/%d/%Y")) - 
      # DOY of first day of first frost-free month
      lubridate::yday(as.Date(paste0("0",aboveFreezing_month, "/01/2024"), 
                                                    format = "%m/%d/%Y"))
    )

# constants for SVP calculation 
#calculate SVP according to Williams et al NatCC 2012 supplementary material -  units haPa
a0<-6.107799961
a1<-0.4436518521
a2<-0.01428945805
a3<-0.0002650648471
a4<-0.000003031240396
a5<-0.00000002034080948
a6<-0.00000000006136820929
## calculating vapor pressure deficit, annual water deficit, and wet degree days (based on code from Adam Noel)

climVar2_1 <- climDat_monthly_1 %>% 
  #slice(23507:23509) %>% 
  # approximation of mean temp (just avg. of max and min, which I realize is not totally accurate)
  mutate(tmean_Jan = (tmax_C_1 + tmin_C_1)/2,
         tmean_Feb = (tmax_C_2 + tmin_C_2)/2,
         tmean_March = (tmax_C_3 + tmin_C_3)/2,
         tmean_April = (tmax_C_4 + tmin_C_4)/2,
         tmean_May = (tmax_C_5 + tmin_C_5)/2,
         tmean_June = (tmax_C_6 + tmin_C_6)/2,
         tmean_July = (tmax_C_7 + tmin_C_7)/2,
         tmean_Aug = (tmax_C_8 + tmin_C_8)/2,
         tmean_Sept = (tmax_C_9 + tmin_C_9)/2,
         tmean_Oct = (tmax_C_10 + tmin_C_10)/2,
         tmean_Nov = (tmax_C_11 + tmin_C_11)/2,
         tmean_Dec = (tmax_C_12 + tmin_C_12)/2,
  ) %>% 
  mutate(
    # monthly water deficit 
    awd_Jan = tmean_Jan*2 - prcp_mm_1,
    awd_Feb = tmean_Feb*2 - prcp_mm_2,
    awd_March = tmean_March*2 - prcp_mm_3,
    awd_April = tmean_April*2 - prcp_mm_4,
    awd_May = tmean_May*2 - prcp_mm_5,
    awd_June = tmean_June*2 - prcp_mm_6, 
    awd_July = tmean_July*2 - prcp_mm_7,
    awd_Aug = tmean_Aug*2 - prcp_mm_8, 
    awd_Sept = tmean_Sept*2 - prcp_mm_9, 
    awd_Oct = tmean_Oct*2 - prcp_mm_10,   
    awd_Nov = tmean_Nov*2 - prcp_mm_11,   
    awd_Dec = tmean_Dec*2 - prcp_mm_12,   
    # monthly wet degree days
    ##aes 
    awdd_Jan =  ifelse(tmean_Jan*2 < prcp_mm_1, tmean_Jan*30, NA),
    awdd_Feb =  ifelse(tmean_Feb*2 < prcp_mm_2, tmean_Feb*30, NA),
    awdd_March =   ifelse(tmean_March*2 < prcp_mm_3, tmean_March*30, NA),
    awdd_April =  ifelse(tmean_April*2 < prcp_mm_4, tmean_April*30, NA),
    awdd_May = ifelse(tmean_May*2 < prcp_mm_5, tmean_May*30, NA),
    awdd_June = ifelse(tmean_June*2 < prcp_mm_6, tmean_June*30, NA),
    awdd_July = ifelse(tmean_July*2 < prcp_mm_7, tmean_July*30, NA), 
    awdd_Aug = ifelse(tmean_Aug*2 < prcp_mm_8, tmean_Aug*30, NA),
    awdd_Sept = ifelse(tmean_Sept*2 < prcp_mm_9, tmean_Sept*30, NA),
    awdd_Oct = ifelse(tmean_Oct*2 < prcp_mm_10, tmean_Oct*30, NA),
    awdd_Nov = ifelse(tmean_Nov*2 < prcp_mm_11, tmean_Nov*30, NA),
    awdd_Dec = ifelse(tmean_Dec*2 < prcp_mm_12, tmean_Dec*30, NA),
   
    # units are Pascals 
    VPD_Jan = ((( a0+ tmean_Jan*(a1+ tmean_Jan *(a2+ tmean_Jan *(a3+ tmean_Jan *(a4 + tmean_Jan *(a5    + tmean_Jan *a6)))))))*100 -  (tmean_Jan))/1000,
    VPD_Feb = ((( a0+ tmean_Feb*(a1+ tmean_Feb *(a2+ tmean_Feb *(a3+ tmean_Feb *(a4 + tmean_Feb *(a5    + tmean_Feb *a6)))))))*100 -  (tmean_Feb))/1000,
    VPD_March = ((( a0+ tmean_March*(a1+ tmean_March *(a2+ tmean_March *(a3+ tmean_March *(a4   + tmean_March *(a5  + tmean_March *a6)))))))*100 -  (tmean_March))/1000,
    VPD_April = ((( a0+ tmean_April*(a1+ tmean_April *(a2+ tmean_April *(a3+ tmean_April *(a4   + tmean_April *(a5  + tmean_April *a6)))))))*100 -  (tmean_April))/1000,
    VPD_May =   ((( a0+ tmean_May*(a1+ tmean_May *(a2+ tmean_May *(a3+ tmean_May *(a4   + tmean_May *(a5    + tmean_May *a6)))))))*100 -  (tmean_May))/1000,
    VPD_June =  ((( a0+ tmean_June*(a1+ tmean_June *(a2+ tmean_June *(a3+ tmean_June *(a4   + tmean_June *(a5   + tmean_June *a6)))))))*100 -  (tmean_June))/1000,
    VPD_July =  ((( a0+ tmean_July*(a1+ tmean_July *(a2+ tmean_July *(a3+ tmean_July *(a4   + tmean_July *(a5   + tmean_July *a6)))))))*100 -  (tmean_July))/1000,
    VPD_Aug =   ((( a0+ tmean_Aug*(a1+ tmean_Aug *(a2+ tmean_Aug *(a3+ tmean_Aug *(a4   + tmean_Aug *(a5    + tmean_Aug *a6)))))))*100 -  (tmean_Aug))/1000,
    VPD_Sept =  ((( a0+ tmean_Sept*(a1+ tmean_Sept *(a2+ tmean_Sept *(a3+ tmean_Sept *(a4   + tmean_Sept *(a5   + tmean_Sept *a6)))))))*100 -  (tmean_Sept))/1000,
    VPD_Oct =   ((( a0+ tmean_Oct*(a1+ tmean_Oct *(a2+ tmean_Oct *(a3+ tmean_Oct *(a4   + tmean_Oct *(a5    + tmean_Oct *a6)))))))*100 -  (tmean_Oct))/1000,
    VPD_Nov =   ((( a0+ tmean_Nov*(a1+ tmean_Nov *(a2+ tmean_Nov *(a3+ tmean_Nov *(a4   + tmean_Nov *(a5    + tmean_Nov *a6)))))))*100 -  (tmean_Nov))/1000,
    VPD_Dec =   ((( a0+ tmean_Dec*(a1+ tmean_Dec *(a2+ tmean_Dec *(a3+ tmean_Dec *(a4   + tmean_Dec *(a5    + tmean_Dec *a6)))))))*100 -  (tmean_Dec))/1000
    ) %>% 
  #calculate annual values
  transmute(#keep = c("year", "Long", "Lat"),
  #mutate(
    # annual water deficit (mm of water over degrees celsius)(sum across all months?)
    tmean = pmap_dbl(.[c("tmean_Jan", "tmean_Feb", "tmean_March", "tmean_April", "tmean_May", "tmean_June", "tmean_July", "tmean_Aug", "tmean_Sept", "tmean_Oct" ,"tmean_Nov", "tmean_Dec")],
                       .f = function(tmean_Jan, tmean_Feb, tmean_March, tmean_April, tmean_May, tmean_June, tmean_July, tmean_Aug, tmean_Sept, tmean_Oct ,tmean_Nov, tmean_Dec, ...) {
                         temp <- sum(tmean_Jan, tmean_Feb, tmean_March, tmean_April, tmean_May, tmean_June, tmean_July, tmean_Aug, tmean_Sept, tmean_Oct ,tmean_Nov, tmean_Dec)/12
                         return(temp)
                       }),
    
    # annual water deficit (mm of water over degrees celsius)(sum across all months?)
    annWaterDeficit = pmap_dbl(.[c("awd_Jan", "awd_Feb", "awd_March", "awd_April", "awd_May", "awd_June", "awd_July", "awd_Aug", "awd_Sept", "awd_Oct" ,"awd_Nov", "awd_Dec")], 
                               .f = function(awd_Jan, awd_Feb, awd_March, awd_April, awd_May, awd_June, awd_July, awd_Aug, awd_Sept, awd_Oct ,awd_Nov, awd_Dec, ...){
                                 temp <- c(awd_Jan, awd_Feb, awd_March, awd_April, awd_May, awd_June, awd_July, awd_Aug, awd_Sept, awd_Oct ,awd_Nov, awd_Dec)
                                 sum(temp[temp>0])
                               }
    ),
    # annual wet degree days (temp*days) (sum only positive values)
    annWetDegDays = pmap_dbl(.[c("awdd_Jan", "awdd_Feb", "awdd_March", "awdd_April", "awdd_May", "awdd_June", "awdd_July", "awdd_Aug", "awdd_Sept", "awdd_Oct" ,"awdd_Nov", "awdd_Dec")],
                             .f = function(awdd_Jan, awdd_Feb, awdd_March, awdd_April, awdd_May, awdd_June, awdd_July, awdd_Aug, awdd_Sept, awdd_Oct ,awdd_Nov, awdd_Dec, ...) 
                             {
                               temp <- c(awdd_Jan, awdd_Feb, awdd_March, awdd_April, awdd_May, awdd_June, awdd_July, awdd_Aug, awdd_Sept, awdd_Oct ,awdd_Nov, awdd_Dec)
                               sum(temp[temp>0], na.rm = TRUE)
                             }
    ),
    # annual average vapor pressure deficit (in milibars) ()
    annVPD_mean = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")], 
                           .f = function(VPD_Jan, VPD_Feb, VPD_March,VPD_April ,VPD_May,VPD_June, VPD_July,VPD_Aug,VPD_Sept,VPD_Oct,VPD_Nov,VPD_Dec) {
      mean(VPD_Jan, VPD_Feb, VPD_March,VPD_April ,VPD_May,VPD_June, VPD_July,VPD_Aug,VPD_Sept,VPD_Oct,VPD_Nov,VPD_Dec)
    }),
    # annual maximum vapor pressure deficit (in milibars) 
    annVPD_max = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")], max),
    # annual minimum vapor pressure deficit (in milibars) 
    annVPD_min = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")], min)
  )


# if duration of frost free days is NA, change to 0 (high elevation points where there aren't any days >0 degrees C)
climVar_1[is.na(climVar_1[,"durationFrostFreeDays"]),"durationFrostFreeDays"] <- 0
# if first month where tmin is above freezing is NA, change to 8 
climVar_1[is.na(climVar_1[,"aboveFreezing_month"]), "aboveFreezing_month"] <- 8

climVar_1 <- cbind(climVar_1, climVar2_1)

rm(climVar2_1)
gc()

## calculate MAP and MAT over past years (a sliding window?)
# function
slidingMetMeans <- function(inDat, start, end) {
  endActual <- end-1 # subtract one so that we're actually looking at the 30, 10, 5, etc. years previous to the "end" year
  outDat <- inDat %>% 
    filter(Year %in% c(start:endActual)) %>% 
    group_by(x, y) %>% 
    summarize(#sweMax_meanAnnAvg = mean(swe_annAvg),
              tmin_meanAnnAvg = mean(Tmin_annAvgOfMonthly),
              tmax_meanAnnAvg = mean(Tmax_annAvgOfMonthly),
              tmean_meanAnnAvg = mean(tmean),
              #vp_meanAnnAvg = mean(vp_annAvg),
              prcp_meanAnnTotal = mean(totalAnnPrecip),
              T_warmestMonth_meanAnnAvg = mean(T_warmestMonth), # temperature of warmest month
              T_coldestMonth_meanAnnAvg = mean(T_coldestMonth), # temperature of coldest month
              precip_wettestMonth_meanAnnAvg = mean(precip_wettestMonth), # precip of wettest month
              precip_driestMonth_meanAnnAvg = mean(precip_driestMonth), # precip of driest month
              precip_Seasonality_meanAnnAvg = mean(precip_Seasonality),
              PrecipTempCorr_meanAnnAvg = mean(PrecipTempCorr),
              aboveFreezing_month_meanAnnAvg = mean(aboveFreezing_month),
              isothermality_meanAnnAvg = mean(isothermality),
              annWaterDeficit_meanAnnAvg = mean(annWaterDeficit),
              annWetDegDays_meanAnnAvg = mean(annWetDegDays),
              annVPD_mean_meanAnnAvg = mean(annVPD_mean),
              annVPD_max_meanAnnAvg = mean(annVPD_max),
              annVPD_min_meanAnnAvg = mean(annVPD_min),
              annVPD_max_95percentile = unname(quantile(annVPD_max, probs = 0.95, na.rm = TRUE)),
              annWaterDeficit_95percentile = unname(quantile(annWaterDeficit, probs = 0.95, na.rm = TRUE)),
              annWetDegDays_5percentile = unname(quantile(annWetDegDays, probs = 0.05, na.rm = TRUE)),
              durationFrostFreeDays_5percentile = unname(quantile(durationFrostFreeDays, probs = 0.05, na.rm = TRUE)),
              durationFrostFreeDays_meanAnnAvg = unname(mean(durationFrostFreeDays))
    )
  return(outDat)
}

# for last 20-year window, which is fewer than the 30 we used in the model-fitting... but I'd have to download even more MACA data, which I don't want to do right now...
annMeans_30yrs <- slidingMetMeans(inDat = climVar_1,
                            start = as.numeric(2099-31), end = 2099)

names(annMeans_30yrs)[3:24] <- paste0(names(annMeans_30yrs)[3:24], "_CLIM")
annMeans_30yrs$End_CLIM <- 2099

# for last 3-year window
annMeans_3yrs <- slidingMetMeans(inDat = climVar_1,
                                 start = as.numeric(2099-4), end = 2099)

names(annMeans_3yrs)[3:24] <- paste0(names(annMeans_3yrs)[3:24], "_3yr")
annMeans_3yrs$End_3yr <- 2099
## add lagged data to the main climate value data.frame
test <- climVar_1 %>% 
  dplyr::select(-c(tmin_C_1:prcp_mm_12)) %>% 
  filter(Year == 2099) %>% 
  #filter(year == 2020) %>% 
  #slice(1:100) %>% 
  left_join(annMeans_30yrs, by = c("Year" = "End_CLIM", 
                                  "x" = "x", 
                                  "y" = "y")) %>% 
  left_join(annMeans_3yrs, by = c("Year" = "End_3yr", 
                                  "x" = "x", 
                                  "y" = "y")
  )

rm(annMeans_30yrs, annMeans_3yrs)
gc()

test$Start_CLIM <- 2099-31

# save intermediate data 
saveRDS(test, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/ForecastedClimateDataForPredictions_BNU-ESM_rcp8_5.rds")
#test <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/ForecastedClimateDataForPredictions_BNU-ESM_rcp8_5.rds")
rm(climVar_1)
gc()

#### calculate anomalies ####
# i.e. how do the 3 yr. lagged values compare to the 20yr lagged values?

anomDat_3yr <- test %>% 
  transmute(
    # compare 3 yr values to 20 yr values
    # tmean as absolute difference
    tmean_meanAnnAvg_3yrAnom = tmean_meanAnnAvg_CLIM - tmean_meanAnnAvg_3yr,
    # tmin as absolute difference
    tmin_meanAnnAvg_3yrAnom = tmin_meanAnnAvg_CLIM - tmin_meanAnnAvg_3yr,
    # tmax as absolute difference
    tmax_meanAnnAvg_3yrAnom = tmax_meanAnnAvg_CLIM - tmax_meanAnnAvg_3yr,
    # vp as % difference
    #vp_meanAnnAvg_3yrAnom = (vp_meanAnnAvg_CLIM - vp_meanAnnAvg_3yr)/vp_meanAnnAvg_CLIM,
    # prcp as % difference
    prcp_meanAnnTotal_3yrAnom = (prcp_meanAnnTotal_CLIM - prcp_meanAnnTotal_3yr)/prcp_meanAnnTotal_CLIM,
    # t warmest month as absolute difference
    T_warmestMonth_meanAnnAvg_3yrAnom = T_warmestMonth_meanAnnAvg_CLIM - T_warmestMonth_meanAnnAvg_3yr,
    # t coldest month as absolute difference
    T_coldestMonth_meanAnnAvg_3yrAnom = T_coldestMonth_meanAnnAvg_CLIM - T_coldestMonth_meanAnnAvg_3yr,
    # precip wettest month as % difference
    precip_wettestMonth_meanAnnAvg_3yrAnom = (precip_wettestMonth_meanAnnAvg_CLIM - precip_wettestMonth_meanAnnAvg_3yr)/precip_wettestMonth_meanAnnAvg_CLIM,
    # precip driest month as % difference
    precip_driestMonth_meanAnnAvg_3yrAnom = (precip_driestMonth_meanAnnAvg_CLIM - precip_driestMonth_meanAnnAvg_3yr)/precip_driestMonth_meanAnnAvg_CLIM,
    # precip seasonality as % difference
    precip_Seasonality_meanAnnAvg_3yrAnom = (precip_Seasonality_meanAnnAvg_CLIM - precip_Seasonality_meanAnnAvg_3yr)/precip_Seasonality_meanAnnAvg_CLIM,
    # precip tempCorr as absolute difference
    PrecipTempCorr_meanAnnAvg_3yrAnom = PrecipTempCorr_meanAnnAvg_CLIM - PrecipTempCorr_meanAnnAvg_3yr,
    # above Freezing month as absolute difference
    aboveFreezing_month_meanAnnAvg_3yrAnom = aboveFreezing_month_meanAnnAvg_CLIM - aboveFreezing_month_meanAnnAvg_3yr,
    # isothermailty as % difference
    isothermality_meanAnnAvg_3yrAnom = isothermality_meanAnnAvg_CLIM - isothermality_meanAnnAvg_3yr,    
    # annual water deficit as % difference
    annWaterDeficit_meanAnnAvg_3yrAnom = ((annWaterDeficit_meanAnnAvg_CLIM+.0001) - annWaterDeficit_meanAnnAvg_3yr)/(annWaterDeficit_meanAnnAvg_CLIM+.0001),
    # wet degree days as % difference
    annWetDegDays_meanAnnAvg_3yrAnom = (annWetDegDays_meanAnnAvg_CLIM - annWetDegDays_meanAnnAvg_3yr)/annWetDegDays_meanAnnAvg_CLIM,
    # mean VPD as absolute difference
    annVPD_mean_meanAnnAvg_3yrAnom = (annVPD_mean_meanAnnAvg_CLIM - annVPD_mean_meanAnnAvg_3yr),
    # min VPD as absolute difference
    annVPD_min_meanAnnAvg_3yrAnom = (annVPD_min_meanAnnAvg_CLIM - annVPD_min_meanAnnAvg_3yr),
    # max VPD as absolute difference
    annVPD_max_meanAnnAvg_3yrAnom = (annVPD_max_meanAnnAvg_CLIM - annVPD_max_meanAnnAvg_3yr),
    # 95th percentile of max VPD as absolute difference 
    annVPD_max_95percentile_3yrAnom = (annVPD_max_95percentile_CLIM - annVPD_max_95percentile_3yr),
    # 95th percentile of annual water deficit as % difference
    annWaterDeficit_95percentile_3yrAnom = ((annWaterDeficit_95percentile_CLIM + .0001) - annWaterDeficit_95percentile_3yr)/(annWaterDeficit_95percentile_CLIM + .0001),
    # 5th percentile of annual wet degree days as % difference 
    annWetDegDays_5percentile_3yrAnom = ((annWetDegDays_5percentile_CLIM + .0001) - annWetDegDays_5percentile_3yr)/(annWetDegDays_5percentile_CLIM + .0001),
    # 5th percentile of frost-free days as absolute difference 
    durationFrostFreeDays_5percentile_3yrAnom = (durationFrostFreeDays_5percentile_CLIM - durationFrostFreeDays_5percentile_3yr),
    # mean of frost free days as absolute difference
    durationFrostFreeDays_meanAnnAvg_3yrAnom = (durationFrostFreeDays_meanAnnAvg_CLIM - durationFrostFreeDays_meanAnnAvg_3yr)
  )

climDat <- cbind(test, 
                 anomDat_3yr
) 

## add soils information 
soilRast <- readRDS("../../../Data_processed/SoilsRaster.rds") 

  crs(soilRast) == crs(test_rast)
# sample soils data for veg. points ---------------------------------------
# sample raster to get values for the points in the cover dataset

soils_df <- soilRast %>% 
  terra::extract(y = pointsSamp #%>% dplyr::select(-x,-y)
                 , xy = TRUE, bind = TRUE) %>% 
  as.data.frame()

# ggplot() + 
#   geom_point(data = climDat, aes(x,y)) + 
#   geom_point(data = soils_df, aes(x, y))
# calculate soils variables w/ cover data ---------------------------------
  soils_new <- 
    soils_df %>% 
    dplyr::mutate(
      # Soil depth 
      soilDepth = pmap_dbl(.[c("horizonThickness_cm_2cm" , "horizonThickness_cm_7cm" , "horizonThickness_cm_15cm" , 
                               "horizonThickness_cm_25cm" , "horizonThickness_cm_35cm" , "horizonThickness_cm_50cm" , 
                               "horizonThickness_cm_70cm" , "horizonThickness_cm_90cm" , "horizonThickness_cm_125cm" , 
                               "horizonThickness_cm_176cm")], sum, na.rm = TRUE),
      #Surface clay (influences how much moisture can get into the profile)
      surfaceClay_perc = clayPerc_2cm) %>% 
    mutate(soilDepth = replace(soilDepth, is.na(horizonThickness_cm_2cm), values = NA)) %>% 
    mutate( 
      # Sand average across depths (avg. weighted by width of layer)
      avgSandPerc_acrossDepth = pmap_dbl(.[c("horizonThickness_cm_2cm" , "horizonThickness_cm_7cm" ,
                                             "horizonThickness_cm_15cm" , "horizonThickness_cm_25cm" ,
                                             "horizonThickness_cm_35cm" , "horizonThickness_cm_50cm" , 
                                             "horizonThickness_cm_70cm" , "horizonThickness_cm_90cm" ,
                                             "horizonThickness_cm_125cm" , "horizonThickness_cm_176cm", 
                                             "sandPerc_2cm", "sandPerc_7cm" , "sandPerc_15cm",
                                             "sandPerc_25cm" , "sandPerc_35cm", "sandPerc_50cm" , 
                                             "sandPerc_70cm", "sandPerc_90cm" ,
                                             "sandPerc_125cm", "sandPerc_176cm", "soilDepth")], 
                                         function(horizonThickness_cm_2cm , horizonThickness_cm_7cm ,
                                                  horizonThickness_cm_15cm ,  horizonThickness_cm_25cm ,
                                                  horizonThickness_cm_35cm , horizonThickness_cm_50cm , 
                                                  horizonThickness_cm_70cm , horizonThickness_cm_90cm ,
                                                  horizonThickness_cm_125cm ,  horizonThickness_cm_176cm, 
                                                  sandPerc_2cm, sandPerc_7cm , sandPerc_15cm,
                                                  sandPerc_25cm , sandPerc_35cm, sandPerc_50cm , 
                                                  sandPerc_70cm, sandPerc_90cm ,
                                                  sandPerc_125cm,sandPerc_176cm, soilDepth) {
                                           y <- sum(c(sandPerc_2cm *  horizonThickness_cm_2cm/soilDepth, 
                                                      sandPerc_7cm *    horizonThickness_cm_7cm/soilDepth, 
                                                      sandPerc_15cm *   horizonThickness_cm_15cm/soilDepth, 
                                                      sandPerc_25cm *   horizonThickness_cm_25cm/soilDepth, 
                                                      sandPerc_35cm *   horizonThickness_cm_35cm/soilDepth, 
                                                      sandPerc_50cm *   horizonThickness_cm_50cm/soilDepth, 
                                                      sandPerc_70cm *   horizonThickness_cm_70cm/soilDepth, 
                                                      sandPerc_90cm *   horizonThickness_cm_90cm/soilDepth, 
                                                      sandPerc_125cm *  horizonThickness_cm_125cm/soilDepth, 
                                                      sandPerc_176cm *  horizonThickness_cm_176cm/soilDepth), 
                                                    na.rm = TRUE)/1 
                                           # following weighted average formula here: weighted average = sum(x * weight)/sum(weights)
                                           return(y)
                                         }
      ),
      # Coarse fragments average across depths (avg. weighted by width of layer)
      avgCoarsePerc_acrossDepth = pmap_dbl(.[c("horizonThickness_cm_2cm" , "horizonThickness_cm_7cm" ,
                                               "horizonThickness_cm_15cm" ,   "horizonThickness_cm_25cm" ,
                                               "horizonThickness_cm_35cm" , "horizonThickness_cm_50cm" , 
                                               "horizonThickness_cm_70cm" , "horizonThickness_cm_90cm" ,
                                               "horizonThickness_cm_125cm" ,  "horizonThickness_cm_176cm", 
                                               "coarsePerc_2cm", "coarsePerc_7cm" , "coarsePerc_15cm",
                                               "coarsePerc_25cm" , "coarsePerc_35cm", "coarsePerc_50cm" ,
                                               "coarsePerc_70cm", "coarsePerc_90cm" ,
                                               "coarsePerc_125cm","coarsePerc_176cm", "soilDepth")], 
                                           function(horizonThickness_cm_2cm , horizonThickness_cm_7cm ,
                                                    horizonThickness_cm_15cm , horizonThickness_cm_25cm ,
                                                    horizonThickness_cm_35cm , horizonThickness_cm_50cm , 
                                                    horizonThickness_cm_70cm , horizonThickness_cm_90cm ,
                                                    horizonThickness_cm_125cm , horizonThickness_cm_176cm,
                                                    coarsePerc_2cm, coarsePerc_7cm , coarsePerc_15cm,
                                                    coarsePerc_25cm , coarsePerc_35cm, coarsePerc_50cm ,
                                                    coarsePerc_70cm, coarsePerc_90cm ,
                                                    coarsePerc_125cm,coarsePerc_176cm, soilDepth) {
                                             y <- sum(c(coarsePerc_2cm *  horizonThickness_cm_2cm/soilDepth, 
                                                        coarsePerc_7cm *    horizonThickness_cm_7cm/soilDepth, 
                                                        coarsePerc_15cm *   horizonThickness_cm_15cm/soilDepth, 
                                                        coarsePerc_25cm *   horizonThickness_cm_25cm/soilDepth, 
                                                        coarsePerc_35cm *   horizonThickness_cm_35cm/soilDepth, 
                                                        coarsePerc_50cm *   horizonThickness_cm_50cm/soilDepth, 
                                                        coarsePerc_70cm *   horizonThickness_cm_70cm/soilDepth, 
                                                        coarsePerc_90cm *   horizonThickness_cm_90cm/soilDepth, 
                                                        coarsePerc_125cm *  horizonThickness_cm_125cm/soilDepth, 
                                                        coarsePerc_176cm *  horizonThickness_cm_176cm/soilDepth), 
                                                      na.rm = TRUE)/1 
                                             # following weighted average formula here: weighted average = sum(x * weight)/sum(weights)
                                             return(y)
                                           }
      ), 
      # soil organic carbon in first 3 cm 
      avgOrganicCarbonPerc_0_3cm = organicCarbonPerc_2cm
    )
  
  
  # # total profile available water-holding capacity
  temp <- soils_new %>% 
    mutate(clayPerc_2cm = clayPerc_2cm/100,
           clayPerc_7cm = clayPerc_7cm/100,
           clayPerc_15cm = clayPerc_15cm/100,
           clayPerc_25cm = clayPerc_25cm/100,
           clayPerc_35cm = clayPerc_35cm/100,
           clayPerc_50cm = clayPerc_50cm/100,
           clayPerc_70cm = clayPerc_70cm/100,
           clayPerc_90cm = clayPerc_90cm/100,
           clayPerc_125cm = clayPerc_125cm/100,
           clayPerc_176cm = clayPerc_176cm/100,
           sandPerc_2cm = sandPerc_2cm/100,
           sandPerc_7cm = sandPerc_7cm/100,
           sandPerc_15cm = sandPerc_15cm/100,
           sandPerc_25cm = sandPerc_25cm/100,
           sandPerc_35cm = sandPerc_35cm/100,
           sandPerc_50cm = sandPerc_50cm/100,
           sandPerc_70cm = sandPerc_70cm/100,
           sandPerc_90cm = sandPerc_90cm/100,
           sandPerc_125cm = sandPerc_125cm/100,
           sandPerc_176cm = sandPerc_176cm/100,
           coarsePerc_2cm = coarsePerc_2cm/100,
           coarsePerc_7cm = coarsePerc_7cm/100,
           coarsePerc_15cm = coarsePerc_15cm/100,
           coarsePerc_25cm = coarsePerc_25cm/100,
           coarsePerc_35cm = coarsePerc_35cm/100,
           coarsePerc_50cm = coarsePerc_50cm/100,
           coarsePerc_70cm = coarsePerc_70cm/100,
           coarsePerc_90cm = coarsePerc_90cm/100,
           coarsePerc_125cm = coarsePerc_125cm/100,
           coarsePerc_176cm = coarsePerc_176cm/100)  
  #slice(1:3) 
  # calculate # # intermediate value 'p' 
  vegSoil_p <- pmap(.l = temp[,c("sandPerc_2cm", "sandPerc_7cm", "sandPerc_15cm", 
                                 "sandPerc_25cm", "sandPerc_35cm", "sandPerc_50cm", 
                                 "sandPerc_70cm", "sandPerc_90cm" ,"sandPerc_125cm", 
                                 "sandPerc_176cm",
                                 "clayPerc_2cm", "clayPerc_7cm" , "clayPerc_15cm", 
                                 "clayPerc_25cm", "clayPerc_35cm", "clayPerc_50cm", 
                                 "clayPerc_70cm", "clayPerc_90cm" ,"clayPerc_125cm", 
                                 "clayPerc_176cm",
                                 "coarsePerc_2cm", "coarsePerc_7cm" , "coarsePerc_15cm", 
                                 "coarsePerc_25cm", "coarsePerc_35cm", "coarsePerc_50cm", 
                                 "coarsePerc_70cm", "coarsePerc_90cm" ,"coarsePerc_125cm", 
                                 "coarsePerc_176cm")], 
                    function (sandPerc_2cm, sandPerc_7cm, sandPerc_15cm, 
                              sandPerc_25cm, sandPerc_35cm, sandPerc_50cm, 
                              sandPerc_70cm, sandPerc_90cm ,sandPerc_125cm, 
                              sandPerc_176cm,
                              clayPerc_2cm, clayPerc_7cm , clayPerc_15cm, 
                              clayPerc_25cm, clayPerc_35cm, clayPerc_50cm, 
                              clayPerc_70cm, clayPerc_90cm ,clayPerc_125cm, 
                              clayPerc_176cm,
                              coarsePerc_2cm, coarsePerc_7cm , coarsePerc_15cm, 
                              coarsePerc_25cm, coarsePerc_35cm, coarsePerc_50cm, 
                              coarsePerc_70cm, coarsePerc_90cm ,coarsePerc_125cm, 
                              coarsePerc_176cm) {
                      p <- rSOILWAT2::ptf_estimate(
                        sand = c(sandPerc_2cm,sandPerc_7cm , sandPerc_15cm,
                                 sandPerc_25cm , sandPerc_35cm, sandPerc_50cm , 
                                 sandPerc_70cm, sandPerc_90cm ,
                                 sandPerc_125cm,sandPerc_176cm),
                        clay = c(clayPerc_2cm,clayPerc_7cm , clayPerc_15cm,
                                 clayPerc_25cm , clayPerc_35cm, clayPerc_50cm , 
                                 clayPerc_70cm, clayPerc_90cm ,
                                 clayPerc_125cm,clayPerc_176cm),
                        fcoarse = c(coarsePerc_2cm, coarsePerc_7cm , coarsePerc_15cm,
                                    coarsePerc_25cm , coarsePerc_35cm, coarsePerc_50cm , 
                                    coarsePerc_70cm, coarsePerc_90cm ,
                                    coarsePerc_125cm,coarsePerc_176cm),
                        swrc_name = "Campbell1974",
                        ptf_name = "Cosby1984"
                      )
                    }
  )
  
# calculate intermediate value 'tmp'
  # reference "temp" data frame (which has the raw soil variables), as well as vegSoil_p, a list which has matrices for p calculated above
  vegSoil_tmp <- map(.x = c(1:nrow(temp)), 
                    function (n) {
                      tmp <- rSOILWAT2::swrc_swp_to_vwc(
                        c(-1.5, -0.033), ##AES should I change this? not totally clear what these values indicate 
                        fcoarse = unlist(as.vector(temp[n,c("coarsePerc_2cm" ,                           
                                           "coarsePerc_7cm" ,  "coarsePerc_15cm",                        
                                           "coarsePerc_25cm",  "coarsePerc_35cm",                        
                                           "coarsePerc_50cm",  "coarsePerc_70cm",                        
                                           "coarsePerc_90cm",  "coarsePerc_125cm",                        
                                           "coarsePerc_176cm")])),
                        swrc = list(name = "Campbell1974", swrcp = vegSoil_p[[n]])
                      )
                    }
  )
  
  
#   # calculate final value 'awc' 
  vegSoil_awc <- map(.x = c(1:nrow(temp)), 
                     function (n) {
                      awc <- temp[n,c("horizonThickness_cm_2cm"  ,                 
                                     "horizonThickness_cm_7cm"  ,                  "horizonThickness_cm_15cm"    ,              
                                     "horizonThickness_cm_25cm" ,                  "horizonThickness_cm_35cm"    ,              
                                     "horizonThickness_cm_50cm" ,                  "horizonThickness_cm_70cm"    ,              
                                     "horizonThickness_cm_90cm" ,                  "horizonThickness_cm_125cm"   ,              
                                     "horizonThickness_cm_176cm")] * as.vector(diff(vegSoil_tmp[[n]])
                                                                               )
                      #AES I assume that I sum these values across the entire profile to get "total profile awc"??
                      totAWC <- sum(awc, na.rm = TRUE)
                     }
  )
  
  
  soils_new$totalAvailableWaterHoldingCapacity <- unlist(vegSoil_awc)


# remove unnecessary soils variables 
  soils_final <- soils_new %>% 
    dplyr::select(-c(clayPerc_2cm:organicCarbonPerc_176cm)) %>% 
    filter(!is.nan(x))
  
  # 
# add soils to climate data
  climDat_test <- 
    climDat %>% 
    st_as_sf(coords = c("x", "y"), crs = st_crs(test_rast))
  soils_final_test <- soils_final %>% 
    st_as_sf(coords = c("x", "y"), crs = st_crs(test_rast))

forecastClimSoilsDat_1 <- climDat_test %>% 
  st_join(st_buffer(soils_final_test, 8000))

## for the second climate model
climVar_2 <- climDat_monthly_2 %>% 
  #slice(1:100) %>% 
  mutate(totalAnnPrecip = rowSums(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")]), # total annual precipitation in mm
         T_warmestMonth = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10",  "tmax_C_11",  "tmax_C_12")], max), # temperature of warmest month
         T_coldestMonth = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10",  "tmin_C_11",  "tmin_C_12")], min), # temperature of coldest month
         Tmin_annAvgOfMonthly = rowSums(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10",  "tmin_C_11",  "tmin_C_12")])/12,
         Tmax_annAvgOfMonthly = rowSums(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10",  "tmax_C_11",  "tmax_C_12")])/12,
         #meanAnnVp = rowMeans(.[28:39]), # annual mean vapor pressure
         precip_wettestMonth = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")],
                                        max), # precip of wettest month
         precip_driestMonth = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")], 
                                       min), # precip of driest month
         precip_Seasonality = pmap_dbl(.[c("prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")],   # coefficient of variation (sd/mean) of precipitation
                                       .f = function(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12, ...) 
                                       {temp <- c(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12)
                                       sd(temp)/mean(temp)
                                       }
         ),
         PrecipTempCorr = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10",  "tmax_C_11",  "tmax_C_12",
                                       "prcp_mm_1", "prcp_mm_2", "prcp_mm_3", "prcp_mm_4", "prcp_mm_5", "prcp_mm_6", "prcp_mm_7", "prcp_mm_8", "prcp_mm_9", "prcp_mm_10" ,"prcp_mm_11", "prcp_mm_12")], #correlation of monthly temp and precip
                                   .f = function(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10,  tmax_C_11,  tmax_C_12,
                                                 prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12, ...) {
                                     cor(y = c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10,  tmax_C_11,  tmax_C_12), 
                                         x = c(prcp_mm_1, prcp_mm_2, prcp_mm_3, prcp_mm_4, prcp_mm_5, prcp_mm_6, prcp_mm_7, prcp_mm_8, prcp_mm_9, prcp_mm_10 ,prcp_mm_11, prcp_mm_12))
                                   }),
         aboveFreezing_month = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10",  "tmin_C_11",  "tmin_C_12")], # month when temp gets above freezing (when tmin > 0 degrees C, so no freeze at night )
                                        .f = function(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12) {
                                          temp <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12)
                                          which(temp > 0)[1] # in degrees C
                                        }),
         lastAboveFreezing_month = pmap_dbl(.[c("tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10",  "tmin_C_11",  "tmin_C_12")], # month when temp gets above freezing (when tmin > 0 degrees C, so no freeze at night )
                                        .f = function(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12) {
                                          temp <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12)
                                          temp2 <- which(temp > 0) # in degrees C
                                          if(length(temp2)>0) {
                                            return(max(temp2))
                                          } else {
                                              return(NA)
                                            }
                                        }),
         
         isothermality = pmap_dbl(.[c("tmax_C_1", "tmax_C_2", "tmax_C_3", "tmax_C_4", "tmax_C_5", "tmax_C_6", "tmax_C_7", "tmax_C_8", "tmax_C_9", "tmax_C_10",  "tmax_C_11",  "tmax_C_12",
                                      "tmin_C_1", "tmin_C_2", "tmin_C_3", "tmin_C_4", "tmin_C_5", "tmin_C_6", "tmin_C_7", "tmin_C_8", "tmin_C_9", "tmin_C_10",  "tmin_C_11",  "tmin_C_12")], # isothermality
                                  .f = function(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10,  tmax_C_11,  tmax_C_12,
                                                tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12, ...) {
                                    tmins <- c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12)
                                    tmaxes <- c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10,  tmax_C_11,  tmax_C_12)
                                    tMaxMax <- max(c(tmax_C_1, tmax_C_2, tmax_C_3, tmax_C_4, tmax_C_5, tmax_C_6, tmax_C_7, tmax_C_8, tmax_C_9, tmax_C_10,  tmax_C_11,  tmax_C_12))
                                    tMinMin <- min(c(tmin_C_1, tmin_C_2, tmin_C_3, tmin_C_4, tmin_C_5, tmin_C_6, tmin_C_7, tmin_C_8, tmin_C_9, tmin_C_10,  tmin_C_11,  tmin_C_12))
                                    mean(tmaxes-tmins)/(tMaxMax-tMinMin) * 100
                                  }),
         
  ) %>% 
  mutate(
    # calculate the duration of frost-free days (in our case here, Frost-free
    # days = (doy of first day of the first month when tmin is >0) - (doy of
    # last day of the lost month when tmin >0))
    # first month when tmin is above freezing is "aboveFreezing_month" in the previous d.f.
    # last month when tmin is above freezing is "lastAboveFreezing_month" in the previous d.f.
    durationFrostFreeDays = 
      # DOY of last day of last frost-free month (just give the 30th, since it
      # probably isn't a bit deal if we use the 30th rather than the 31st in
      # months when there is a 31st)
      lubridate::yday(as.Date(paste0(lastAboveFreezing_month, "/30/2024"), 
                              format = "%m/%d/%Y")) - 
      # DOY of first day of first frost-free month
      lubridate::yday(as.Date(paste0("0",aboveFreezing_month, "/01/2024"), 
                                                    format = "%m/%d/%Y"))
    )

climVar2_2<- climDat_monthly_2%>% 
  #slice(23507:23509) %>% 
  # approximation of mean temp (just avg. of max and min, which I realize is not totally accurate)
  mutate(tmean_Jan = (tmax_C_1 + tmin_C_1)/2,
         tmean_Feb = (tmax_C_2 + tmin_C_2)/2,
         tmean_March = (tmax_C_3 + tmin_C_3)/2,
         tmean_April = (tmax_C_4 + tmin_C_4)/2,
         tmean_May = (tmax_C_5 + tmin_C_5)/2,
         tmean_June = (tmax_C_6 + tmin_C_6)/2,
         tmean_July = (tmax_C_7 + tmin_C_7)/2,
         tmean_Aug = (tmax_C_8 + tmin_C_8)/2,
         tmean_Sept = (tmax_C_9 + tmin_C_9)/2,
         tmean_Oct = (tmax_C_10 + tmin_C_10)/2,
         tmean_Nov = (tmax_C_11 + tmin_C_11)/2,
         tmean_Dec = (tmax_C_12 + tmin_C_12)/2,
  ) %>% 
  mutate(
    # monthly water deficit 
    awd_Jan = tmean_Jan*2 - prcp_mm_1,
    awd_Feb = tmean_Feb*2 - prcp_mm_2,
    awd_March = tmean_March*2 - prcp_mm_3,
    awd_April = tmean_April*2 - prcp_mm_4,
    awd_May = tmean_May*2 - prcp_mm_5,
    awd_June = tmean_June*2 - prcp_mm_6, 
    awd_July = tmean_July*2 - prcp_mm_7,
    awd_Aug = tmean_Aug*2 - prcp_mm_8, 
    awd_Sept = tmean_Sept*2 - prcp_mm_9, 
    awd_Oct = tmean_Oct*2 - prcp_mm_10,   
    awd_Nov = tmean_Nov*2 - prcp_mm_11,   
    awd_Dec = tmean_Dec*2 - prcp_mm_12,   
    # monthly wet degree days
    ##aes 
    awdd_Jan =  ifelse(tmean_Jan*2 < prcp_mm_1, tmean_Jan*30, NA),
    awdd_Feb =  ifelse(tmean_Feb*2 < prcp_mm_2, tmean_Feb*30, NA),
    awdd_March =   ifelse(tmean_March*2 < prcp_mm_3, tmean_March*30, NA),
    awdd_April =  ifelse(tmean_April*2 < prcp_mm_4, tmean_April*30, NA),
    awdd_May = ifelse(tmean_May*2 < prcp_mm_5, tmean_May*30, NA),
    awdd_June = ifelse(tmean_June*2 < prcp_mm_6, tmean_June*30, NA),
    awdd_July = ifelse(tmean_July*2 < prcp_mm_7, tmean_July*30, NA), 
    awdd_Aug = ifelse(tmean_Aug*2 < prcp_mm_8, tmean_Aug*30, NA),
    awdd_Sept = ifelse(tmean_Sept*2 < prcp_mm_9, tmean_Sept*30, NA),
    awdd_Oct = ifelse(tmean_Oct*2 < prcp_mm_10, tmean_Oct*30, NA),
    awdd_Nov = ifelse(tmean_Nov*2 < prcp_mm_11, tmean_Nov*30, NA),
    awdd_Dec = ifelse(tmean_Dec*2 < prcp_mm_12, tmean_Dec*30, NA),
   
    # units are Pascals 
    VPD_Jan = ((( a0+ tmean_Jan*(a1+ tmean_Jan *(a2+ tmean_Jan *(a3+ tmean_Jan *(a4 + tmean_Jan *(a5    + tmean_Jan *a6)))))))*100 -  (tmean_Jan))/1000,
    VPD_Feb = ((( a0+ tmean_Feb*(a1+ tmean_Feb *(a2+ tmean_Feb *(a3+ tmean_Feb *(a4 + tmean_Feb *(a5    + tmean_Feb *a6)))))))*100 -  (tmean_Feb))/1000,
    VPD_March = ((( a0+ tmean_March*(a1+ tmean_March *(a2+ tmean_March *(a3+ tmean_March *(a4   + tmean_March *(a5  + tmean_March *a6)))))))*100 -  (tmean_March))/1000,
    VPD_April = ((( a0+ tmean_April*(a1+ tmean_April *(a2+ tmean_April *(a3+ tmean_April *(a4   + tmean_April *(a5  + tmean_April *a6)))))))*100 -  (tmean_April))/1000,
    VPD_May =   ((( a0+ tmean_May*(a1+ tmean_May *(a2+ tmean_May *(a3+ tmean_May *(a4   + tmean_May *(a5    + tmean_May *a6)))))))*100 -  (tmean_May))/1000,
    VPD_June =  ((( a0+ tmean_June*(a1+ tmean_June *(a2+ tmean_June *(a3+ tmean_June *(a4   + tmean_June *(a5   + tmean_June *a6)))))))*100 -  (tmean_June))/1000,
    VPD_July =  ((( a0+ tmean_July*(a1+ tmean_July *(a2+ tmean_July *(a3+ tmean_July *(a4   + tmean_July *(a5   + tmean_July *a6)))))))*100 -  (tmean_July))/1000,
    VPD_Aug =   ((( a0+ tmean_Aug*(a1+ tmean_Aug *(a2+ tmean_Aug *(a3+ tmean_Aug *(a4   + tmean_Aug *(a5    + tmean_Aug *a6)))))))*100 -  (tmean_Aug))/1000,
    VPD_Sept =  ((( a0+ tmean_Sept*(a1+ tmean_Sept *(a2+ tmean_Sept *(a3+ tmean_Sept *(a4   + tmean_Sept *(a5   + tmean_Sept *a6)))))))*100 -  (tmean_Sept))/1000,
    VPD_Oct =   ((( a0+ tmean_Oct*(a1+ tmean_Oct *(a2+ tmean_Oct *(a3+ tmean_Oct *(a4   + tmean_Oct *(a5    + tmean_Oct *a6)))))))*100 -  (tmean_Oct))/1000,
    VPD_Nov =   ((( a0+ tmean_Nov*(a1+ tmean_Nov *(a2+ tmean_Nov *(a3+ tmean_Nov *(a4   + tmean_Nov *(a5    + tmean_Nov *a6)))))))*100 -  (tmean_Nov))/1000,
    VPD_Dec =   ((( a0+ tmean_Dec*(a1+ tmean_Dec *(a2+ tmean_Dec *(a3+ tmean_Dec *(a4   + tmean_Dec *(a5    + tmean_Dec *a6)))))))*100 -  (tmean_Dec))/1000
    ) %>% 
  #calculate annual values
  transmute(#keep = c("year", "Long", "Lat"),
  #mutate(
    # annual water deficit (mm of water over degrees celsius)(sum across all months?)
    tmean = pmap_dbl(.[c("tmean_Jan", "tmean_Feb", "tmean_March", "tmean_April", "tmean_May", "tmean_June", "tmean_July", "tmean_Aug", "tmean_Sept", "tmean_Oct" ,"tmean_Nov", "tmean_Dec")],
                       .f = function(tmean_Jan, tmean_Feb, tmean_March, tmean_April, tmean_May, tmean_June, tmean_July, tmean_Aug, tmean_Sept, tmean_Oct ,tmean_Nov, tmean_Dec, ...) {
                         temp <- sum(tmean_Jan, tmean_Feb, tmean_March, tmean_April, tmean_May, tmean_June, tmean_July, tmean_Aug, tmean_Sept, tmean_Oct ,tmean_Nov, tmean_Dec)/12
                         return(temp)
                       }),
    
    # annual water deficit (mm of water over degrees celsius)(sum across all months?)
    annWaterDeficit = pmap_dbl(.[c("awd_Jan", "awd_Feb", "awd_March", "awd_April", "awd_May", "awd_June", "awd_July", "awd_Aug", "awd_Sept", "awd_Oct" ,"awd_Nov", "awd_Dec")], 
                               .f = function(awd_Jan, awd_Feb, awd_March, awd_April, awd_May, awd_June, awd_July, awd_Aug, awd_Sept, awd_Oct ,awd_Nov, awd_Dec, ...){
                                 temp <- c(awd_Jan, awd_Feb, awd_March, awd_April, awd_May, awd_June, awd_July, awd_Aug, awd_Sept, awd_Oct ,awd_Nov, awd_Dec)
                                 sum(temp[temp>0])
                               }
    ),
    # annual wet degree days (temp*days) (sum only positive values)
    annWetDegDays = pmap_dbl(.[c("awdd_Jan", "awdd_Feb", "awdd_March", "awdd_April", "awdd_May", "awdd_June", "awdd_July", "awdd_Aug", "awdd_Sept", "awdd_Oct" ,"awdd_Nov", "awdd_Dec")],
                             .f = function(awdd_Jan, awdd_Feb, awdd_March, awdd_April, awdd_May, awdd_June, awdd_July, awdd_Aug, awdd_Sept, awdd_Oct ,awdd_Nov, awdd_Dec, ...) 
                             {
                               temp <- c(awdd_Jan, awdd_Feb, awdd_March, awdd_April, awdd_May, awdd_June, awdd_July, awdd_Aug, awdd_Sept, awdd_Oct ,awdd_Nov, awdd_Dec)
                               sum(temp[temp>0], na.rm = TRUE)
                             }
    ),
    # annual average vapor pressure deficit (in milibars) ()
    annVPD_mean = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")], 
                           .f = function(VPD_Jan, VPD_Feb, VPD_March,VPD_April ,VPD_May,VPD_June, VPD_July,VPD_Aug,VPD_Sept,VPD_Oct,VPD_Nov,VPD_Dec) {
      mean(VPD_Jan, VPD_Feb, VPD_March,VPD_April ,VPD_May,VPD_June, VPD_July,VPD_Aug,VPD_Sept,VPD_Oct,VPD_Nov,VPD_Dec)
    }),
    # annual maximum vapor pressure deficit (in milibars) 
    annVPD_max = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")], max),
    # annual minimum vapor pressure deficit (in milibars) 
    annVPD_min = pmap_dbl(.[c("VPD_Jan", "VPD_Feb", "VPD_March","VPD_April" ,"VPD_May","VPD_June", "VPD_July","VPD_Aug","VPD_Sept","VPD_Oct","VPD_Nov","VPD_Dec")], min)
  )


# if duration of frost free days is NA, change to 0 (high elevation points where there aren't any days >0 degrees C)
climVar_2[is.na(climVar_2[,"durationFrostFreeDays"]),"durationFrostFreeDays"] <- 0
# if first month where tmin is above freezing is NA, change to 8 
climVar_2[is.na(climVar_2[,"aboveFreezing_month"]), "aboveFreezing_month"] <- 8

climVar_2 <- cbind(climVar_2, climVar2_2)

rm(climVar2_2)
gc()

## calculate MAP and MAT over past years (a sliding window?)

# for last 20-year window, which is fewer than the 30 we used in the model-fitting... but I'd have to download even more MACA data, which I don't want to do right now...
annMeans_30yrs  <- slidingMetMeans(inDat = climVar_2,
                            start = as.numeric(2099-31), end = 2099)

names(annMeans_30yrs)[3:24] <- paste0(names(annMeans_30yrs)[3:24], "_CLIM")
annMeans_30yrs$End_CLIM <- 2099
# for last 3-year window
annMeans_3yrs <- slidingMetMeans(inDat = climVar_2,
                                 start = as.numeric(2099-4), end = 2099)

names(annMeans_3yrs)[3:24] <- paste0(names(annMeans_3yrs)[3:24], "_3yr")
annMeans_3yrs$End_3yr <- 2099
## add lagged data to the main climate value data.frame
test <- climVar_2 %>% 
  dplyr::select(-c(tmin_C_1:prcp_mm_12)) %>% 
  filter(Year == 2099) %>% 
  #filter(year == 2020) %>% 
  #slice(1:100) %>% 
  left_join(annMeans_30yrs, by = c("Year" = "End_CLIM", 
                                  "x" = "x", 
                                  "y" = "y")) %>% 
  left_join(annMeans_3yrs, by = c("Year" = "End_3yr", 
                                  "x" = "x", 
                                  "y" = "y")
  )

rm(annMeans_30yrs, annMeans_3yrs)
gc()

test$Start_CLIM <- 2099-31

# save intermediate data 
saveRDS(test, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/ForecastedClimateDataForPredictions_IPSL-CM5A-MR_rcp8_5.rds")
#test <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/ForecastedClimateDataForPredictions_IPSL-CM5A-MR_rcp8_5.rds")
rm(climVar_2)
gc()

#### calculate anomalies ####
# i.e. how do the 3 yr. lagged values compare to the 20yr lagged values?

anomDat_3yr <- test %>% 
  transmute(
    # compare 3 yr values to 20 yr values
    # tmean as absolute difference
    tmean_meanAnnAvg_3yrAnom = tmean_meanAnnAvg_CLIM - tmean_meanAnnAvg_3yr,
    # tmin as absolute difference
    tmin_meanAnnAvg_3yrAnom = tmin_meanAnnAvg_CLIM - tmin_meanAnnAvg_3yr,
    # tmax as absolute difference
    tmax_meanAnnAvg_3yrAnom = tmax_meanAnnAvg_CLIM - tmax_meanAnnAvg_3yr,
    # vp as % difference
    #vp_meanAnnAvg_3yrAnom = (vp_meanAnnAvg_CLIM - vp_meanAnnAvg_3yr)/vp_meanAnnAvg_CLIM,
    # prcp as % difference
    prcp_meanAnnTotal_3yrAnom = (prcp_meanAnnTotal_CLIM - prcp_meanAnnTotal_3yr)/prcp_meanAnnTotal_CLIM,
    # t warmest month as absolute difference
    T_warmestMonth_meanAnnAvg_3yrAnom = T_warmestMonth_meanAnnAvg_CLIM - T_warmestMonth_meanAnnAvg_3yr,
    # t coldest month as absolute difference
    T_coldestMonth_meanAnnAvg_3yrAnom = T_coldestMonth_meanAnnAvg_CLIM - T_coldestMonth_meanAnnAvg_3yr,
    # precip wettest month as % difference
    precip_wettestMonth_meanAnnAvg_3yrAnom = (precip_wettestMonth_meanAnnAvg_CLIM - precip_wettestMonth_meanAnnAvg_3yr)/precip_wettestMonth_meanAnnAvg_CLIM,
    # precip driest month as % difference
    precip_driestMonth_meanAnnAvg_3yrAnom = (precip_driestMonth_meanAnnAvg_CLIM - precip_driestMonth_meanAnnAvg_3yr)/precip_driestMonth_meanAnnAvg_CLIM,
    # precip seasonality as % difference
    precip_Seasonality_meanAnnAvg_3yrAnom = (precip_Seasonality_meanAnnAvg_CLIM - precip_Seasonality_meanAnnAvg_3yr)/precip_Seasonality_meanAnnAvg_CLIM,
    # precip tempCorr as absolute difference
    PrecipTempCorr_meanAnnAvg_3yrAnom = PrecipTempCorr_meanAnnAvg_CLIM - PrecipTempCorr_meanAnnAvg_3yr,
    # above Freezing month as absolute difference
    aboveFreezing_month_meanAnnAvg_3yrAnom = aboveFreezing_month_meanAnnAvg_CLIM - aboveFreezing_month_meanAnnAvg_3yr,
    # isothermailty as % difference
    isothermality_meanAnnAvg_3yrAnom = isothermality_meanAnnAvg_CLIM - isothermality_meanAnnAvg_3yr,    
    # annual water deficit as % difference
    annWaterDeficit_meanAnnAvg_3yrAnom = ((annWaterDeficit_meanAnnAvg_CLIM+.0001) - annWaterDeficit_meanAnnAvg_3yr)/(annWaterDeficit_meanAnnAvg_CLIM+.0001),
    # wet degree days as % difference
    annWetDegDays_meanAnnAvg_3yrAnom = (annWetDegDays_meanAnnAvg_CLIM - annWetDegDays_meanAnnAvg_3yr)/annWetDegDays_meanAnnAvg_CLIM,
    # mean VPD as absolute difference
    annVPD_mean_meanAnnAvg_3yrAnom = (annVPD_mean_meanAnnAvg_CLIM - annVPD_mean_meanAnnAvg_3yr),
    # min VPD as absolute difference
    annVPD_min_meanAnnAvg_3yrAnom = (annVPD_min_meanAnnAvg_CLIM - annVPD_min_meanAnnAvg_3yr),
    # max VPD as absolute difference
    annVPD_max_meanAnnAvg_3yrAnom = (annVPD_max_meanAnnAvg_CLIM - annVPD_max_meanAnnAvg_3yr),
    # 95th percentile of max VPD as absolute difference 
    annVPD_max_95percentile_3yrAnom = (annVPD_max_95percentile_CLIM - annVPD_max_95percentile_3yr),
    # 95th percentile of annual water deficit as % difference
    annWaterDeficit_95percentile_3yrAnom = ((annWaterDeficit_95percentile_CLIM + .0001) - annWaterDeficit_95percentile_3yr)/(annWaterDeficit_95percentile_CLIM + .0001),
    # 5th percentile of annual wet degree days as % difference 
    annWetDegDays_5percentile_3yrAnom = ((annWetDegDays_5percentile_CLIM + .0001) - annWetDegDays_5percentile_3yr)/(annWetDegDays_5percentile_CLIM + .0001),
    # 5th percentile of frost-free days as absolute difference 
    durationFrostFreeDays_5percentile_3yrAnom = (durationFrostFreeDays_5percentile_CLIM - durationFrostFreeDays_5percentile_3yr),
    # mean of frost free days as absolute difference
    durationFrostFreeDays_meanAnnAvg_3yrAnom = (durationFrostFreeDays_meanAnnAvg_CLIM - durationFrostFreeDays_meanAnnAvg_3yr)
  )

climDat <- cbind(test, 
                 anomDat_3yr
) 

## add soils information 
  climDat_test <- 
    climDat %>% 
    st_as_sf(coords = c("x", "y"), crs = st_crs(test_rast))
  soils_final_test <- soils_final %>% 
    st_as_sf(coords = c("x", "y"), crs = st_crs(test_rast))
  
forecastClimSoilsDat_2 <- climDat_test %>% 
  st_join(st_buffer(soils_final_test, 8000))

# prepare for use in models
## Model # 1
#forecastClimSoilsDat_1 <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_BNU-ESM_rcp8_5.rds")
forecastClimSoilsDat_1$x <- st_coordinates(forecastClimSoilsDat_1)[,1]
forecastClimSoilsDat_1$y <- st_coordinates(forecastClimSoilsDat_1)[,2]
## add ecoregion data 
  forecastClimSoilsDat_1$newRegion <- NA
  forecastClimSoilsDat_1[st_covered_by(forecastClimSoilsDat_1, mapRegions[mapRegions$newRegion== "Forest",], sparse = FALSE), "newRegion"] <- "Forest"
  forecastClimSoilsDat_1[st_covered_by(forecastClimSoilsDat_1, mapRegions[mapRegions$newRegion== "dryShrubGrass",], sparse = FALSE), "newRegion"] <- "dryShrubGrass"

# rename
forecastClimSoilsDat_1 <- forecastClimSoilsDat_1 %>% 
  st_drop_geometry() %>% 
  dplyr::select(x, y, Year, tmin_meanAnnAvg_CLIM:durationFrostFreeDays_meanAnnAvg_CLIM, 
         tmean_meanAnnAvg_3yrAnom:durationFrostFreeDays_meanAnnAvg_3yrAnom,
          soilDepth:totalAvailableWaterHoldingCapacity, newRegion) %>% 
rename("tmin" = tmin_meanAnnAvg_CLIM, 
     "tmax" = tmax_meanAnnAvg_CLIM, #1 
     "tmean" = tmean_meanAnnAvg_CLIM, 
     "prcp" = prcp_meanAnnTotal_CLIM, 
     "t_warm" = T_warmestMonth_meanAnnAvg_CLIM,
     "t_cold" = T_coldestMonth_meanAnnAvg_CLIM, 
     "prcp_wet" = precip_wettestMonth_meanAnnAvg_CLIM,
     "prcp_dry" = precip_driestMonth_meanAnnAvg_CLIM, 
     "prcp_seasonality" = precip_Seasonality_meanAnnAvg_CLIM, #2
     "prcpTempCorr" = PrecipTempCorr_meanAnnAvg_CLIM,  #3
     "abvFreezingMonth" = aboveFreezing_month_meanAnnAvg_CLIM, 
     "isothermality" = isothermality_meanAnnAvg_CLIM, #4
     "annWatDef" = annWaterDeficit_meanAnnAvg_CLIM, 
     "annWetDegDays" = annWetDegDays_meanAnnAvg_CLIM,
     "VPD_mean" = annVPD_mean_meanAnnAvg_CLIM, 
     "VPD_max" = annVPD_max_meanAnnAvg_CLIM, #5
     "VPD_min" = annVPD_min_meanAnnAvg_CLIM, #6
     "VPD_max_95" = annVPD_max_95percentile_CLIM, 
     "annWatDef_95" = annWaterDeficit_95percentile_CLIM, 
     "annWetDegDays_5" = annWetDegDays_5percentile_CLIM, 
     "frostFreeDays_5" = durationFrostFreeDays_5percentile_CLIM, 
     "frostFreeDays" = durationFrostFreeDays_meanAnnAvg_CLIM, 
     "soilDepth" = soilDepth, #7
     "clay" = surfaceClay_perc, 
     "sand" = avgSandPerc_acrossDepth, #8
     "coarse" = avgCoarsePerc_acrossDepth, #9
     "carbon" = avgOrganicCarbonPerc_0_3cm, #10
     "AWHC" = totalAvailableWaterHoldingCapacity,
     ## anomaly variables
     tmean_anom = tmean_meanAnnAvg_3yrAnom, #15
     tmin_anom = tmin_meanAnnAvg_3yrAnom, #16
     tmax_anom = tmax_meanAnnAvg_3yrAnom, #17
    prcp_anom = prcp_meanAnnTotal_3yrAnom, #18
      t_warm_anom = T_warmestMonth_meanAnnAvg_3yrAnom,  #19
     t_cold_anom = T_coldestMonth_meanAnnAvg_3yrAnom, #20
      prcp_wet_anom = precip_wettestMonth_meanAnnAvg_3yrAnom, #21
      precp_dry_anom = precip_driestMonth_meanAnnAvg_3yrAnom,  #22
    prcp_seasonality_anom = precip_Seasonality_meanAnnAvg_3yrAnom, #23 
     prcpTempCorr_anom = PrecipTempCorr_meanAnnAvg_3yrAnom, #24
      aboveFreezingMonth_anom = aboveFreezing_month_meanAnnAvg_3yrAnom, #25  
    isothermality_anom = isothermality_meanAnnAvg_3yrAnom, #26
       annWatDef_anom = annWaterDeficit_meanAnnAvg_3yrAnom, #27
     annWetDegDays_anom = annWetDegDays_meanAnnAvg_3yrAnom,  #28
      VPD_mean_anom = annVPD_mean_meanAnnAvg_3yrAnom, #29
      VPD_min_anom = annVPD_min_meanAnnAvg_3yrAnom,  #30
      VPD_max_anom = annVPD_max_meanAnnAvg_3yrAnom,  #31
     VPD_max_95_anom = annVPD_max_95percentile_3yrAnom, #32
      annWatDef_95_anom = annWaterDeficit_95percentile_3yrAnom, #33 
      annWetDegDays_5_anom = annWetDegDays_5percentile_3yrAnom ,  #34
    frostFreeDays_5_anom = durationFrostFreeDays_5percentile_3yrAnom, #35 
      frostFreeDays_anom = durationFrostFreeDays_meanAnnAvg_3yrAnom #36
  ) 

## Model # 2
# forecastClimSoilsDat_2 <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_IPSL-CM5A-MR_rcp8_5.rds")
forecastClimSoilsDat_2 <- st_as_sf(forecastClimSoilsDat_2, coords )
forecastClimSoilsDat_2$x <- st_coordinates(forecastClimSoilsDat_2)[,1]
forecastClimSoilsDat_2$y <- st_coordinates(forecastClimSoilsDat_2)[,2]
# get ecoregions
forecastClimSoilsDat_2$newRegion <- NA
  forecastClimSoilsDat_2[st_covered_by(forecastClimSoilsDat_2, mapRegions[mapRegions$newRegion== "Forest",], sparse = FALSE), "newRegion"] <- "Forest"
  forecastClimSoilsDat_2[st_covered_by(forecastClimSoilsDat_2, mapRegions[mapRegions$newRegion== "dryShrubGrass",], sparse = FALSE), "newRegion"] <- "dryShrubGrass"

# rename
forecastClimSoilsDat_2 <- forecastClimSoilsDat_2 %>% 
  st_drop_geometry() %>% 
  dplyr::select(x, y, Year, tmin_meanAnnAvg_CLIM:durationFrostFreeDays_meanAnnAvg_CLIM, 
         tmean_meanAnnAvg_3yrAnom:durationFrostFreeDays_meanAnnAvg_3yrAnom,
          soilDepth:totalAvailableWaterHoldingCapacity, newRegion) %>% 
rename("tmin" = tmin_meanAnnAvg_CLIM, 
     "tmax" = tmax_meanAnnAvg_CLIM, #1 
     "tmean" = tmean_meanAnnAvg_CLIM, 
     "prcp" = prcp_meanAnnTotal_CLIM, 
     "t_warm" = T_warmestMonth_meanAnnAvg_CLIM,
     "t_cold" = T_coldestMonth_meanAnnAvg_CLIM, 
     "prcp_wet" = precip_wettestMonth_meanAnnAvg_CLIM,
     "prcp_dry" = precip_driestMonth_meanAnnAvg_CLIM, 
     "prcp_seasonality" = precip_Seasonality_meanAnnAvg_CLIM, #2
     "prcpTempCorr" = PrecipTempCorr_meanAnnAvg_CLIM,  #3
     "abvFreezingMonth" = aboveFreezing_month_meanAnnAvg_CLIM, 
     "isothermality" = isothermality_meanAnnAvg_CLIM, #4
     "annWatDef" = annWaterDeficit_meanAnnAvg_CLIM, 
     "annWetDegDays" = annWetDegDays_meanAnnAvg_CLIM,
     "VPD_mean" = annVPD_mean_meanAnnAvg_CLIM, 
     "VPD_max" = annVPD_max_meanAnnAvg_CLIM, #5
     "VPD_min" = annVPD_min_meanAnnAvg_CLIM, #6
     "VPD_max_95" = annVPD_max_95percentile_CLIM, 
     "annWatDef_95" = annWaterDeficit_95percentile_CLIM, 
     "annWetDegDays_5" = annWetDegDays_5percentile_CLIM, 
     "frostFreeDays_5" = durationFrostFreeDays_5percentile_CLIM, 
     "frostFreeDays" = durationFrostFreeDays_meanAnnAvg_CLIM, 
     "soilDepth" = soilDepth, #7
     "clay" = surfaceClay_perc, 
     "sand" = avgSandPerc_acrossDepth, #8
     "coarse" = avgCoarsePerc_acrossDepth, #9
     "carbon" = avgOrganicCarbonPerc_0_3cm, #10
     "AWHC" = totalAvailableWaterHoldingCapacity,
     ## anomaly variables
     tmean_anom = tmean_meanAnnAvg_3yrAnom, #15
     tmin_anom = tmin_meanAnnAvg_3yrAnom, #16
     tmax_anom = tmax_meanAnnAvg_3yrAnom, #17
    prcp_anom = prcp_meanAnnTotal_3yrAnom, #18
      t_warm_anom = T_warmestMonth_meanAnnAvg_3yrAnom,  #19
     t_cold_anom = T_coldestMonth_meanAnnAvg_3yrAnom, #20
      prcp_wet_anom = precip_wettestMonth_meanAnnAvg_3yrAnom, #21
      precp_dry_anom = precip_driestMonth_meanAnnAvg_3yrAnom,  #22
    prcp_seasonality_anom = precip_Seasonality_meanAnnAvg_3yrAnom, #23 
     prcpTempCorr_anom = PrecipTempCorr_meanAnnAvg_3yrAnom, #24
      aboveFreezingMonth_anom = aboveFreezing_month_meanAnnAvg_3yrAnom, #25  
    isothermality_anom = isothermality_meanAnnAvg_3yrAnom, #26
       annWatDef_anom = annWaterDeficit_meanAnnAvg_3yrAnom, #27
     annWetDegDays_anom = annWetDegDays_meanAnnAvg_3yrAnom,  #28
      VPD_mean_anom = annVPD_mean_meanAnnAvg_3yrAnom, #29
      VPD_min_anom = annVPD_min_meanAnnAvg_3yrAnom,  #30
      VPD_max_anom = annVPD_max_meanAnnAvg_3yrAnom,  #31
     VPD_max_95_anom = annVPD_max_95percentile_3yrAnom, #32
      annWatDef_95_anom = annWaterDeficit_95percentile_3yrAnom, #33 
      annWetDegDays_5_anom = annWetDegDays_5percentile_3yrAnom ,  #34
    frostFreeDays_5_anom = durationFrostFreeDays_5percentile_3yrAnom, #35 
      frostFreeDays_anom = durationFrostFreeDays_meanAnnAvg_3yrAnom #36
  ) 

## Get the scaling factors for the data used to fit the models (scaling is done to entire dataset, so only need to get once for all models), and apply those same scaling factors to the data we'll predict with 
# get the scaling factors 
scaleParams <- modDat_1_s %>% 
  dplyr::select(tmin_s:AWHC_s) %>% 
  reframe(across(all_of(names(.)), attributes)) 

## For first climate model
# apply the scaling factors to the contemporary climate data 
namesToScale_1 <- forecastClimSoilsDat_1 %>% 
  dplyr::select(tmin:frostFreeDays, tmean_anom:frostFreeDays_anom, soilDepth:AWHC) %>% 
  names()

forecastClimSoilsDat_scaled_1 <- map(namesToScale_1, .f = function(x) {
  x_new <- (forecastClimSoilsDat_1[,x] - scaleParams[,paste0(x, "_s")]$`scaled:center`)/scaleParams[,paste0(x, "_s")]$`scaled:scale`
  return(data.frame(x_new))
}) %>% 
  purrr::list_cbind()
names(forecastClimSoilsDat_scaled_1) <- paste0(namesToScale_1, "_s")

forecastClimSoilsDatPred_1 <- forecastClimSoilsDat_1 %>% 
  dplyr::select(x:Year, newRegion) %>% 
  cbind(forecastClimSoilsDat_scaled_1)
names(forecastClimSoilsDatPred_1)[5:54] <- str_remove(names(forecastClimSoilsDatPred_1)[5:54], pattern = "_s$")

prednames_s <-  modDat_1_s %>%
  dplyr::select(tmin_s:AWHC_s) %>%
  names()
prednames <- str_replace(prednames_s, pattern = "_s$", replacement = "")

## For first climate model
# apply the scaling factors to the contemporary climate data 
namesToScale_2 <- forecastClimSoilsDat_2 %>% 
  dplyr::select(tmin:frostFreeDays, tmean_anom:frostFreeDays_anom, soilDepth:AWHC) %>% 
  names()

forecastClimSoilsDat_scaled_2 <- map(namesToScale_2, .f = function(x) {
  x_new <- (forecastClimSoilsDat_2[,x] - scaleParams[,paste0(x, "_s")]$`scaled:center`)/scaleParams[,paste0(x, "_s")]$`scaled:scale`
  return(data.frame(x_new))
}) %>% 
  purrr::list_cbind()
names(forecastClimSoilsDat_scaled_2) <- paste0(namesToScale_2, "_s")

forecastClimSoilsDatPred_2 <- forecastClimSoilsDat_2 %>% 
  dplyr::select(x:Year, newRegion) %>% 
  cbind(forecastClimSoilsDat_scaled_2)
names(forecastClimSoilsDatPred_2)[5:54] <- str_remove(names(forecastClimSoilsDatPred_2)[5:54], pattern = "_s$")

## save the scaled data for the first climate model 
saveRDS(forecastClimSoilsDatPred_1, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_BNU-ESM_rcp8_5.rds")

## save the scaled data for the second climate model 
saveRDS(forecastClimSoilsDatPred_2, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_IPSL-CM5A-MR_rcp8_5.rds")

# save the unscaled data for the first climate model
saveRDS(forecastClimSoilsDat_1, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_BNU-ESM_rcp8_5_UNSCALED.rds")

# save the unscaled data for the second climate model
saveRDS(forecastClimSoilsDat_2, "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_IPSL-CM5A-MR_rcp8_5_UNSCALED.rds")

} else {
  # read in scaled data
 forecastClimSoilsDatPred_1 <- readRDS(file = "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_BNU-ESM_rcp8_5.rds")
 forecastClimSoilsDatPred_2 <- readRDS(file = "../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_IPSL-CM5A-MR_rcp8_5.rds")
 # read in unscaled data 
 forecastClimSoilsDat_1 <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_BNU-ESM_rcp8_5_UNSCALED.rds")
forecastClimSoilsDat_2 <- readRDS("../../../Data_processed/CoverData/IntermediateAnalysisFiles/Final_ForecastedClimateDataAndSoilsDataForPredictions_IPSL-CM5A-MR_rcp8_5_UNSCALED.rds")

}

Predict for ‘level 1’ of cover types

Predict for grass/shrub total herbaceous cover: 1SE lambda model

Read in the best lambda model object

# read in model objects (is the trim anomaly version)
bestLambdaMod_GS_totHerb <- readRDS("./models/betaLASSO/TotalHerbaceousCover_shrubGrass_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_oneSELambdaGLM.rds")

ModelSpec_bestLambda <- getModelStatement(coefficientTable = grassShrub_totalHerb_trimAnoms,
                                                    modelName <- "coefficientValue_bestLambda", 
                                                    responseVar <- "TotalHerbaceousCover")

This is the 1SE Lambda model equation if the inputs are scaled:

(ModelSpec_bestLambda$scaledInputVars_ModelStatement)
## [1] "TotalHerbaceousCover~ exp(-0.919224029 +  0.226424194*tmean +  0.199667543*prcp + -0.006645681*prcp_seasonality +  0.255616862*prcpTempCorr + -0.067077337*isothermality + -0.137859482*sand + -0.075215916*coarse +  0.188211132*AWHC + -0.008632610*isothermality_anom + -0.835761794*I(prcp^2) +  0.607788406*I(prcpTempCorr^2) + -0.154134489*I(isothermality^2) + -0.027736198*I(prcpTempCorr_anom^2) +  0.060212571*I(sand^2) +  0.036930730*I(coarse^2) +  0.243114077*I(carbon^2) + -0.074220406*I(AWHC^2) +  0.017154809*isothermality:isothermality_anom +  0.427892115*prcp:isothermality +  0.221794309*prcp_seasonality:isothermality + -0.022384725*prcpTempCorr:isothermality_anom +  0.508207457*prcp:prcpTempCorr +  0.413700347*tmean:prcp +  0.046455810*prcp_seasonality:prcp_seasonality_anom +  0.299827722*prcp_seasonality:prcpTempCorr +  0.018032821*prcpTempCorr:prcp_seasonality_anom + -0.340340111*tmean:prcpTempCorr +  0.089955100*sand:AWHC) - 2"

This is the 1SE Lambda model equation if the inputs are not scaled:

(ModelSpec_bestLambda$unscaledInputVars_scaledModelStatement)
## [1] "TotalHerbaceousCover~ exp(-0.919224029 +  0.226424194*((tmean - 10.128868063) / 4.820305195) +  0.199667543*((prcp - 613.807482136) / 502.16616755) + -0.006645681*((prcp_seasonality - 0.922874288) / 0.245115393) +  0.255616862*((prcpTempCorr - -0.120168217) / 0.410373104) + -0.067077337*((isothermality - 38.131295504) / 5.017482043) + -0.137859482*((sand - 47.700975096) / 16.735018944) + -0.075215916*((coarse - 12.778661958) / 11.312037701) +  0.188211132*((AWHC - 13.675056673) / 5.155918864) + -0.008632610*((isothermality_anom - 0.504344509) / 1.294064496)  + -0.835761794*I(((prcp - 613.807482136) / 502.16616755)^2) +  0.607788406*I(((prcpTempCorr - -0.120168217) / 0.410373104)^2) + -0.154134489*I(((isothermality - 38.131295504) / 5.017482043)^2) + -0.027736198*I(((prcpTempCorr_anom - 0.00832419) / 0.119050826)^2) +  0.060212571*I(((sand - 47.700975096) / 16.735018944)^2) +  0.036930730*I(((coarse - 12.778661958) / 11.312037701)^2) +  0.243114077*I(((carbon - 3.67729377) / 6.403824534)^2) + -0.074220406*I(((AWHC - 13.675056673) / 5.155918864)^2) +  0.017154809*((isothermality - 38.131295504) / 5.017482043):((isothermality_anom - 0.504344509) / 1.294064496)  +  0.427892115*((prcp - 613.807482136) / 502.16616755):((isothermality - 38.131295504) / 5.017482043) +  0.221794309*((prcp_seasonality - 0.922874288) / 0.245115393):((isothermality - 38.131295504) / 5.017482043) + -0.022384725*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality_anom - 0.504344509) / 1.294064496)  +  0.508207457*((prcp - 613.807482136) / 502.16616755):((prcpTempCorr - -0.120168217) / 0.410373104) +  0.413700347*((tmean - 10.128868063) / 4.820305195):((prcp - 613.807482136) / 502.16616755) +  0.046455810*((prcp_seasonality - 0.922874288) / 0.245115393):((prcp_seasonality_anom - -0.024139995) / 0.116006989)  +  0.299827722*((prcp_seasonality - 0.922874288) / 0.245115393):((prcpTempCorr - -0.120168217) / 0.410373104) +  0.018032821*((prcpTempCorr - -0.120168217) / 0.410373104):((prcp_seasonality_anom - -0.024139995) / 0.116006989)  + -0.340340111*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr - -0.120168217) / 0.410373104) +  0.089955100*((sand - 47.700975096) / 16.735018944):((AWHC - 13.675056673) / 5.155918864)) - 2"

Now, predict with contemporary and future climate data

# predict w/ best SE lambda model
bestLambda_GS_totHerb_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = bestLambdaMod_GS_totHerb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_GS_totHerb_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = bestLambdaMod_GS_totHerb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_GS_totHerb_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
                                                           modelObject = bestLambdaMod_GS_totHerb)

# predict w/ best model
plotObs_GS_totHerb <- bestLambda_GS_totHerb_predict %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "modelPreds", 
                   fun = mean, na.rm = TRUE)  
    
  

# get the extent of this particular raster, and crop it accordingly
tempExt <- crds(plotObs_GS_totHerb, na.rm = TRUE)

plotObs_GS_totHerb_2 <- plotObs_GS_totHerb %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_GS_totHerb_bestLambdaFuture1 <- bestLambda_GS_totHerb_predictFuture_1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_GS_totHerb_bestLambdaFuture1_2 <- plotObs_GS_totHerb_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_GS_totHerb_bestLambdaFuture2 <- bestLambda_GS_totHerb_predictFuture_2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_GS_totHerb_bestLambdaFuture2_2 <- plotObs_GS_totHerb_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_GS_totHerb <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "TotalHerbaceousCover", 
                   fun = mean, na.rm = TRUE)

plotObservations_GS_totHerb_2 <- plotObservations_GS_totHerb %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map_bestLambda_GS_totHerb <- ggplot() +
geom_spatraster(data = plotObs_GS_totHerb_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_GS_totHerb_2)),fill=NA ) +
labs(title = paste0("Predictions of totalHerbaceousCover in the 
                    grass/shrub ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_GS_totHerb_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_GS_totHerb_2)[c(2,4)])

map_bestLambda_GS_totHerb_future1 <- ggplot() +
geom_spatraster(data = plotObs_GS_totHerb_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_GS_totHerb_2)),fill=NA ) +
labs(title = paste0("Predictions of totalHerbaceousCover in the 
                    grass/shrub ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_GS_totHerb_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_GS_totHerb_2)[c(2,4)])

map_bestLambda_GS_totHerb_future2 <- ggplot() +
geom_spatraster(data = plotObs_GS_totHerb_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_GS_totHerb_2)),fill=NA ) +
labs(title = paste0("Predictions of totalHerbaceousCover in the 
                    grass/shrub ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_GS_totHerb_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_GS_totHerb_2)[c(2,4)])

map_obs_GS_totHerb <- ggplot() +
  geom_spatraster(data = plotObservations_GS_totHerb) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_GS_totHerb_2)),fill=NA ) +
labs(title = paste0("Observations of totalHerbaceousCover")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_GS_totHerb_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_GS_totHerb_2)[c(2,4)])

hist <- ggplot(bestLambda_GS_totHerb_predict) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_GS_totHerb_predict[bestLambda_GS_totHerb_predict$newRegion == "dryShrubGrass",],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")+ 
  xlim(c(0,1))

hist_bestlambdaFuture1 <-  ggplot(bestLambda_GS_totHerb_predictFuture_1) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_GS_totHerb_predictFuture_1[bestLambda_GS_totHerb_predictFuture_1$newRegion == "dryShrubGrass",],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")+ 
  xlim(c(0,1))

hist_bestlambdaFuture2 <-  ggplot(bestLambda_GS_totHerb_predictFuture_2) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_GS_totHerb_predictFuture_2[bestLambda_GS_totHerb_predictFuture_2$newRegion == "dryShrubGrass",],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")+ 
  xlim(c(0,1))

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(TotalHerbaceousCover), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = modDat_1_s[modDat_1_s$newRegion == "dryShrubGrass",],
               aes(x = TotalHerbaceousCover), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")+ 
  xlim(c(0,1))

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_GS_totHerb_2 - plotObs_GS_totHerb_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      grass-shrub model of TotalHerbaceousCover"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))+ 
  xlim(c(-1,1))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_GS_totHerb_bestLambdaFuture1_2 - plotObs_GS_totHerb_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n grass-shrub model of TotalHerbaceousCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  xlim(c(-1,1))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_GS_totHerb_bestLambdaFuture2_2 - plotObs_GS_totHerb_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n grass-shrub model of TotalHerbaceousCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  xlim(c(-1,1))

## conglomerate figure

  ggarrange(map_obs_GS_totHerb, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map_bestLambda_GS_totHerb, map_bestLambda_GS_totHerb_future1, map_bestLambda_GS_totHerb_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

### Predict for forest total herbaceous - best lambda model Read in the objects

# read in model objects (is the trim anomaly version)
 bestLambdaMod_F_totHerb <- readRDS("./models/betaLASSO/TotalHerbaceousCover_forest_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")

ModelSpec_bestLambda_F_totHerb <- getModelStatement(coefficientTable = forest_totalHerb_trimAnoms,
                                                    modelName <- "coefficientValue_bestLambda", 
                                                    responseVar <- "TotalHerbaceousCover")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_bestLambda_F_totHerb$scaledInputVars_ModelStatement)
## [1] "TotalHerbaceousCover~ exp(-1.13602873 + -0.06131127*prcp +  0.06237282*prcp_dry +  0.04037369*prcpTempCorr + -0.32578840*isothermality + -0.20493917*sand + -0.03292348*coarse +  0.12309801*AWHC + -0.11108167*isothermality_anom +  0.03128713*I(isothermality^2) +  0.13053926*I(sand^2) +  0.08683120*prcp:isothermality + -0.01761919*prcp_dry:isothermality_anom + -0.13684263*isothermality_anom:tmean +  0.06391473*prcp_dry:prcp_anom +  0.20880852*sand:AWHC +  0.03492179*clay:carbon + -0.02652128*coarse:carbon + -0.05128408*sand:carbon) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_bestLambda_F_totHerb$unscaledInputVars_scaledModelStatement)
## [1] "TotalHerbaceousCover~ exp(-1.13602873 + -0.06131127*((prcp - 613.807482136) / 502.16616755) +  0.06237282*((prcp_dry - 5.007463659) / 8.212611388) +  0.04037369*((prcpTempCorr - -0.120168217) / 0.410373104) + -0.32578840*((isothermality - 38.131295504) / 5.017482043) + -0.20493917*((sand - 47.700975096) / 16.735018944) + -0.03292348*((coarse - 12.778661958) / 11.312037701) +  0.12309801*((AWHC - 13.675056673) / 5.155918864) + -0.11108167*((isothermality_anom - 0.504344509) / 1.294064496)  +  0.03128713*I(((isothermality - 38.131295504) / 5.017482043)^2) +  0.13053926*I(((sand - 47.700975096) / 16.735018944)^2) +  0.08683120*((prcp - 613.807482136) / 502.16616755):((isothermality - 38.131295504) / 5.017482043) + -0.01761919*((prcp_dry - 5.007463659) / 8.212611388):((isothermality_anom - 0.504344509) / 1.294064496)  + -0.13684263*((isothermality_anom - 0.504344509) / 1.294064496) :((tmean - 10.128868063) / 4.820305195) +  0.06391473*((prcp_dry - 5.007463659) / 8.212611388):((prcp_anom - 0.021823908) / 0.147734326)  +  0.20880852*((sand - 47.700975096) / 16.735018944):((AWHC - 13.675056673) / 5.155918864) +  0.03492179*((clay - 18.493644224) / 9.080523406):((carbon - 3.67729377) / 6.403824534) + -0.02652128*((coarse - 12.778661958) / 11.312037701):((carbon - 3.67729377) / 6.403824534) + -0.05128408*((sand - 47.700975096) / 16.735018944):((carbon - 3.67729377) / 6.403824534)) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_F_totHerb_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = bestLambdaMod_F_totHerb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_F_totHerb_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = bestLambdaMod_F_totHerb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_F_totHerb_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
                                                           modelObject = bestLambdaMod_F_totHerb)

# predict w/ best model
plotObs <- bestLambda_F_totHerb_predict %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "modelPreds", 
                   fun = mean, na.rm = TRUE)  
    
  


plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- bestLambda_F_totHerb_predictFuture_1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- bestLambda_F_totHerb_predictFuture_2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_F_totHerb <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "TotalHerbaceousCover", 
                   fun = mean, na.rm = TRUE)

plotObservations_F_totHerb_2 <- plotObservations_F_totHerb %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalHerbaceousCover in the 
                    forest ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalHerbaceousCover in the 
                    forest ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalHerbaceousCover in the 
                    forest ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_F_totHerb <- ggplot() +
  geom_spatraster(data = plotObservations_F_totHerb_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of TotalHerbaceousCover")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(bestLambda_F_totHerb_predict) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_F_totHerb_predict[bestLambda_F_totHerb_predict$newRegion %in% c("westForest", "eastForest"),],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(bestLambda_F_totHerb_predictFuture_1) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_F_totHerb_predictFuture_1[bestLambda_F_totHerb_predictFuture_1$newRegion == "Forest",],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(bestLambda_F_totHerb_predictFuture_2) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_F_totHerb_predictFuture_2[bestLambda_F_totHerb_predictFuture_2$newRegion == "Forest",],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(TotalHerbaceousCover), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = modDat_1_s[modDat_1_s$newRegion == "Forest",],
               aes(x = TotalHerbaceousCover), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_F_totHerb_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      Forest model of TotalHerbaceousCover"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n forest model of TotalHerbaceousCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n forest model of TotalHerbaceousCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_F_totHerb, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of TotalHerbaceousCover with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

Predict for grass/shrub Total Tree cover - best lambda model

# read in model objects (is the trim anomaly version)
  bestLambdaMod_GS_totTree <- readRDS("./models/betaLASSO/TotalTreeCover_shrubGrass_noTLP_FALSE_removeAnomaliesTRUE_bestLambdaGLM.rds")

ModelSpec_bestlambda_GS_totTree <- getModelStatement(coefficientTable = grassShrub_totalTree_trimAnoms,
                                                    modelName <- "coefficientValue_bestLambda", 
                                                    responseVar <- "TotalTreeCover")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_bestlambda_GS_totTree$scaledInputVars_ModelStatement)
## [1] "TotalTreeCover~ exp(-1.96097394 +  1.29554801*prcp + -0.26462323*prcp_seasonality + -0.05824317*sand + -0.37661550*AWHC + -0.18577846*I(sand^2)) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_bestlambda_GS_totTree$unscaledInputVars_scaledModelStatement)
## [1] "TotalTreeCover~ exp(-1.96097394 +  1.29554801*((prcp - 613.807482136) / 502.16616755) + -0.26462323*((prcp_seasonality - 0.922874288) / 0.245115393) + -0.05824317*((sand - 47.700975096) / 16.735018944) + -0.37661550*((AWHC - 13.675056673) / 5.155918864) + -0.18577846*I(((sand - 47.700975096) / 16.735018944)^2)) - 2"

Predict with model specification for grass/shrub total tree cover

# predict w/ best SE lambda model
bestLambda_GS_totTree_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = bestLambdaMod_GS_totTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_GS_totTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = bestLambdaMod_GS_totTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_GS_totTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
                                                           modelObject = bestLambdaMod_GS_totTree)

# predict w/ best model
plotObs <- bestLambda_GS_totTree_predict %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "modelPreds", 
                   fun = mean, na.rm = TRUE)  
    
  

# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- bestLambda_GS_totTree_predictFuture_1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- bestLambda_GS_totTree_predictFuture_2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_GS_totTree <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "TotalTreeCover", 
                   fun = mean, na.rm = TRUE)

plotObservations_GS_totTree_2 <- plotObservations_GS_totTree %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the 
                    grass/shrub ecoregion 
                    using contemporary climate data"),
      subtitle = "1/2 SE Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the 
                    grass/shrub ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "1/2 SE Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the 
                    grass/shrub ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "1/2 SE Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_GS_totTree <- ggplot() +
  geom_spatraster(data = plotObservations_GS_totTree_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of TotalTreeCover")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(bestLambda_GS_totTree_predict) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_GS_totTree_predict[bestLambda_GS_totTree_predict$newRegion == "dryShrubGrass",],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")+ 
  xlim(c(0,1))

hist_bestlambdaFuture1 <-  ggplot(bestLambda_GS_totTree_predictFuture_1) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_GS_totTree_predictFuture_1[bestLambda_GS_totTree_predictFuture_1$newRegion == "dryShrubGrass",],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")+ 
  xlim(c(0,1))

hist_bestlambdaFuture2 <-  ggplot(bestLambda_GS_totTree_predictFuture_2) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_GS_totTree_predictFuture_2[bestLambda_GS_totTree_predictFuture_2$newRegion == "dryShrubGrass",],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")+ 
  xlim(c(0,1))

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(TotalTreeCover), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = modDat_1_s[modDat_1_s$newRegion == "dryShrubGrass",],
               aes(x = TotalTreeCover), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")+ 
  xlim(c(0,1))

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_GS_totTree_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      grass-shrub model of TotalTreeCover"),
     subtitle = "using predictions from the
     1/2 SE Lambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))+ 
  xlim(c(-1,1))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n grass-shrub model of TotalTreeCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the
     1/2 SE Lambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  xlim(c(-1,1))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n grass-shrub model of TotalTreeCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the 
    1/2 SE Lambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency")  + 
  xlim(c(-1,1))

## conglomerate figure

  #ggarrange(map_obs_GS_totTree, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of TotalTreeCover with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

Predict for forest total tree cover - best lambda model

Read in the objects

# read in model objects (is the trim anomaly version)
 bestLambdaMod_F_totTree <- readRDS("./models/betaLASSO/TotalTreeCover_forest_noTLP_FALSE_removeAnomaliesTRUE_trimAnom_bestLambdaGLM.rds")

ModelSpec_bestLambda_F_totTree <- getModelStatement(coefficientTable = forest_totalTree_trimAnoms,
                                                    modelName <- "coefficientValue_bestLambda", 
                                                    responseVar <- "TotalTreeCover")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_bestLambda_F_totTree$scaledInputVars_ModelStatement)
## [1] "TotalTreeCover~ exp(-1.04718912 +  0.23180799*tmean +  0.26619282*prcp +  0.16834074*prcp_dry + -0.11768337*isothermality +  0.02769937*carbon +  0.06042716*AWHC + -0.05442983*prcp:isothermality +  0.21149397*prcp_dry:prcpTempCorr +  0.03115144*tmean:prcp_dry + -0.28756504*tmean:prcpTempCorr + -0.06997256*AWHC:clay + -0.06115585*carbon:clay +  0.04767956*carbon:coarse +  0.08350038*clay:sand) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_bestLambda_F_totTree$unscaledInputVars_scaledModelStatement)
## [1] "TotalTreeCover~ exp(-1.04718912 +  0.23180799*((tmean - 10.128868063) / 4.820305195) +  0.26619282*((prcp - 613.807482136) / 502.16616755) +  0.16834074*((prcp_dry - 5.007463659) / 8.212611388) + -0.11768337*((isothermality - 38.131295504) / 5.017482043) +  0.02769937*((carbon - 3.67729377) / 6.403824534) +  0.06042716*((AWHC - 13.675056673) / 5.155918864) + -0.05442983*((prcp - 613.807482136) / 502.16616755):((isothermality - 38.131295504) / 5.017482043) +  0.21149397*((prcp_dry - 5.007463659) / 8.212611388):((prcpTempCorr - -0.120168217) / 0.410373104) +  0.03115144*((tmean - 10.128868063) / 4.820305195):((prcp_dry - 5.007463659) / 8.212611388) + -0.28756504*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr - -0.120168217) / 0.410373104) + -0.06997256*((AWHC - 13.675056673) / 5.155918864):((clay - 18.493644224) / 9.080523406) + -0.06115585*((carbon - 3.67729377) / 6.403824534):((clay - 18.493644224) / 9.080523406) +  0.04767956*((carbon - 3.67729377) / 6.403824534):((coarse - 12.778661958) / 11.312037701) +  0.08350038*((clay - 18.493644224) / 9.080523406):((sand - 47.700975096) / 16.735018944)) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_F_totTree_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = bestLambdaMod_F_totTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_F_totTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = bestLambdaMod_F_totTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_F_totTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
                                                           modelObject = bestLambdaMod_F_totTree)

# predict w/ best model
plotObs <- bestLambda_F_totTree_predict %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "modelPreds", 
                   fun = mean, na.rm = TRUE)  
    
  

# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- bestLambda_F_totTree_predictFuture_1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- bestLambda_F_totTree_predictFuture_2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_F_totTree <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "TotalTreeCover", 
                   fun = mean, na.rm = TRUE)

plotObservations_F_totTree_2 <- plotObservations_F_totTree %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the 
                    forest ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the 
                    forest ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of TotalTreeCover in the 
                    forest ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_F_totTree <- ggplot() +
  geom_spatraster(data = plotObservations_F_totTree_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of TotalTreeCover")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(bestLambda_F_totTree_predict) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_F_totTree_predict[bestLambda_F_totTree_predict$newRegion %in% c("westForest", "eastForest"),],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(bestLambda_F_totTree_predictFuture_1) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_F_totTree_predictFuture_1[bestLambda_F_totTree_predictFuture_1$newRegion == "Forest",],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(bestLambda_F_totTree_predictFuture_2) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = bestLambda_F_totTree_predictFuture_2[bestLambda_F_totTree_predictFuture_2$newRegion == "Forest",],
               aes(x = modelPreds), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(TotalTreeCover), fill = "lightgrey", col = "darkgrey") + 
  geom_density(data = modDat_1_s[modDat_1_s$newRegion == "Forest",],
               aes(x = TotalTreeCover), fill = "orchid", col = "orchid", alpha = .3) +
  xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_F_totTree_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      Forest model of TotalTreeCover"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n forest model of TotalTreeCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n forest model of TotalTreeCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_F_totTree, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of TotalTreeCover with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

Shrub cover, CONUS-wide - best lambda model

Read in the objects

# read in model objects (is the trim anomaly version)
 bestLambdaMod_CONUS_shrub <- readRDS("./models/betaLASSO/ShrubCover_CONUS_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")

ModelSpec_bestLambda_CONUS_shrub <- getModelStatement(coefficientTable = CONUS_shrub_trimAnoms,
                                                    modelName <- "coefficientValue_bestLambda", 
                                                    responseVar <- "ShrubCover")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_bestLambda_CONUS_shrub$scaledInputVars_ModelStatement)
## [1] "ShrubCover~ exp(-1.661164268 +  0.129505697*prcp + -0.167549718*prcp_seasonality + -0.275834281*prcpTempCorr +  0.108831411*sand +  0.002957918*coarse + -0.050089034*isothermality_anom + -0.043288814*I(sand^2) + -0.008170561*I(AWHC^2) + -0.006961275*isothermality:annWetDegDays +  0.066565499*isothermality_anom:annWetDegDays + -0.136840654*prcpTempCorr:annWetDegDays + -0.034824804*isothermality_anom:isothermality +  0.120453433*isothermality:tmean +  0.026857654*prcp:prcp_seasonality_anom +  0.078229283*prcpTempCorr:tmean) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_bestLambda_CONUS_shrub$unscaledInputVars_scaledModelStatement)
## [1] "ShrubCover~ exp(-1.661164268 +  0.129505697*((prcp - 613.807482136) / 502.16616755) + -0.167549718*((prcp_seasonality - 0.922874288) / 0.245115393) + -0.275834281*((prcpTempCorr - -0.120168217) / 0.410373104) +  0.108831411*((sand - 47.700975096) / 16.735018944) +  0.002957918*((coarse - 12.778661958) / 11.312037701) + -0.050089034*((isothermality_anom - 0.504344509) / 1.294064496)  + -0.043288814*I(((sand - 47.700975096) / 16.735018944)^2) + -0.008170561*I(((AWHC - 13.675056673) / 5.155918864)^2) + -0.006961275*((isothermality - 38.131295504) / 5.017482043):((annWetDegDays - 1764.581754742) / 1160.387887503) +  0.066565499*((isothermality_anom - 0.504344509) / 1.294064496) :((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.136840654*((prcpTempCorr - -0.120168217) / 0.410373104):((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.034824804*((isothermality_anom - 0.504344509) / 1.294064496) :((isothermality - 38.131295504) / 5.017482043) +  0.120453433*((isothermality - 38.131295504) / 5.017482043):((tmean - 10.128868063) / 4.820305195) +  0.026857654*((prcp - 613.807482136) / 502.16616755):((prcp_seasonality_anom - -0.024139995) / 0.116006989)  +  0.078229283*((prcpTempCorr - -0.120168217) / 0.410373104):((tmean - 10.128868063) / 4.820305195)) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_CONUS_shrub_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = bestLambdaMod_CONUS_shrub)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_shrub_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = bestLambdaMod_CONUS_shrub)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_shrub_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
                                                           modelObject = bestLambdaMod_CONUS_shrub)

# predict w/ best model
plotObs <- bestLambda_CONUS_shrub_predict %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "modelPreds", 
                   fun = mean, na.rm = TRUE)  
    
# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- bestLambda_CONUS_shrub_predictFuture_1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- bestLambda_CONUS_shrub_predictFuture_2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_CONUS_shrub <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "ShrubCover", 
                   fun = mean, na.rm = TRUE)

plotObservations_CONUS_shrub_2 <- plotObservations_CONUS_shrub %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of ShrubCover in the 
                    CONUS ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of ShrubCover in the 
                    CONUS ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of ShrubCover in the 
                    CONUS ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_CONUS_shrub <- ggplot() +
  geom_spatraster(data = plotObservations_CONUS_shrub_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of ShrubCover")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(bestLambda_CONUS_shrub_predict) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(bestLambda_CONUS_shrub_predictFuture_1) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(bestLambda_CONUS_shrub_predictFuture_2) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(ShrubCover), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_CONUS_shrub_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      CONUS model of ShrubCover"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n CONUS-wide model of ShrubCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n CONUS-wide model of ShrubCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_CONUS_shrub, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of ShrubCover with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

Bare Ground Cover cover, CONUS-wide - 1SE lambda model

Read in the objects

# read in model objects (is the trim anomaly version)
 oneSELambdaMod_CONUS_bareGround <- readRDS("./models/betaLASSO/BareGroundCover_CONUS_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_oneSELambdaGLM.rds")

ModelSpec_oneSELambdaMod_CONUS_bareGround <- getModelStatement(coefficientTable = CONUS_bareGround_trimAnoms,
                                                    modelName <- "coefficientValue_1seLambda", 
                                                    responseVar <- "BareGroundCover")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_oneSELambdaMod_CONUS_bareGround$scaledInputVars_ModelStatement)
## [1] "BareGroundCover~ exp(-1.940092121 +  0.278982563*tmean +  0.211638828*prcpTempCorr +  0.185247506*isothermality + -1.249089156*annWetDegDays + -0.391035245*coarse +  0.089170108*AWHC + -0.080908042*isothermality_anom +  0.037020465*annWetDegDays_anom + -0.114629109*I(tmean^2) + -0.114716023*I(prcpTempCorr^2) + -0.007955779*I(isothermality_anom^2) +  0.026297723*I(sand^2) +  0.041591386*I(coarse^2) +  0.260144916*annWetDegDays:prcp +  0.177933407*prcpTempCorr:isothermality +  0.011483867*sand + -0.005898276*I(annWetDegDays_anom^2)) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_oneSELambdaMod_CONUS_bareGround$unscaledInputVars_scaledModelStatement)
## [1] "BareGroundCover~ exp(-1.940092121 +  0.278982563*((tmean - 10.128868063) / 4.820305195) +  0.211638828*((prcpTempCorr - -0.120168217) / 0.410373104) +  0.185247506*((isothermality - 38.131295504) / 5.017482043) + -1.249089156*((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.391035245*((coarse - 12.778661958) / 11.312037701) +  0.089170108*((AWHC - 13.675056673) / 5.155918864) + -0.080908042*((isothermality_anom - 0.504344509) / 1.294064496)  +  0.037020465*((annWetDegDays_anom - 0.01940939) / 0.210157273) + -0.114629109*I(((tmean - 10.128868063) / 4.820305195)^2) + -0.114716023*I(((prcpTempCorr - -0.120168217) / 0.410373104)^2) + -0.007955779*I(((isothermality_anom - 0.504344509) / 1.294064496) ^2) +  0.026297723*I(((sand - 47.700975096) / 16.735018944)^2) +  0.041591386*I(((coarse - 12.778661958) / 11.312037701)^2) +  0.260144916*((annWetDegDays - 1764.581754742) / 1160.387887503):((prcp - 613.807482136) / 502.16616755) +  0.177933407*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) +  0.011483867*((sand - 47.700975096) / 16.735018944) + -0.005898276*I(((annWetDegDays_anom - 0.01940939) / 0.210157273)^2)) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_CONUS_bareGround_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = oneSELambdaMod_CONUS_bareGround)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_bareGround_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = oneSELambdaMod_CONUS_bareGround)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_bareGround_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
                                                           modelObject = oneSELambdaMod_CONUS_bareGround)

# predict w/ best model
plotObs <- bestLambda_CONUS_bareGround_predict %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "modelPreds", 
                   fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- bestLambda_CONUS_bareGround_predictFuture_1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- bestLambda_CONUS_bareGround_predictFuture_2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "modelPreds", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_CONUS_bareGround <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "BareGroundCover", 
                   fun = mean, na.rm = TRUE)

plotObservations_CONUS_bareGround_2 <- plotObservations_CONUS_bareGround %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of BareGroundCover in the 
                    CONUS ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of BareGroundCover in the 
                    CONUS ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Predictions of BareGroundCover in the 
                    CONUS ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_CONUS_bareGround <- ggplot() +
  geom_spatraster(data = plotObservations_CONUS_bareGround_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of BareGroundCover")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(bestLambda_CONUS_bareGround_predict) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(bestLambda_CONUS_bareGround_predictFuture_1) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(bestLambda_CONUS_bareGround_predictFuture_2) + 
  geom_density(aes(modelPreds), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(BareGroundCover), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_CONUS_bareGround_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      CONUS model of BareGroundCover"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n CONUS-wide model of BareGroundCover; \n (models with predictions with modeled climate data from model BNU-ESM model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for \n CONUS-wide model of BareGroundCover; \n (models with predictions with modeled climate data from model IPSL-CM5A-MR model - \n models with predictions from contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_CONUS_bareGround, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of BareGroundCover with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

Predict for ‘level 2’ of cover types

C3 as proportion of total herbaceous, CONUS-wide - 1SE lambda model

Read in the objects

# read in model objects (is the trim anomaly version)
 oneSELambdaMod_CONUS_C3 <- readRDS("./models/betaLASSO/C3GramCover_prop_CONUS_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_oneSELambdaGLM.rds")

ModelSpec_oneSELambdaMod_CONUS_C3 <- getModelStatement(coefficientTable = CONUS_c3_trimAnoms,
                                                    modelName <- "coefficientValue_1seLambda", 
                                                    responseVar <- "c3 cover percentage")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_oneSELambdaMod_CONUS_C3$scaledInputVars_ModelStatement)
## [1] "c3 cover percentage~ exp( 0.18542223 + -0.44696465*tmean + -0.40362010*prcpTempCorr + -0.38780455*isothermality + -0.18796883*annWetDegDays +  0.05532026*prcp_seasonality_anom +  0.11808213*prcpTempCorr_anom + -0.11221305*annWetDegDays_anom + -0.03980364*I(prcp_seasonality^2) + -0.33614836*I(isothermality^2) + -0.03789658*I(isothermality_anom^2) + -0.05062253*I(sand^2) + -0.07158871*I(AWHC^2) +  0.28768848*isothermality:annWetDegDays + -0.51370522*prcpTempCorr:isothermality +  0.12544456*sand:AWHC +  0.16612760*sand:coarse +  0.71815988*prcpTempCorr:prcp) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_oneSELambdaMod_CONUS_C3$unscaledInputVars_scaledModelStatement)
## [1] "c3 cover percentage~ exp( 0.18542223 + -0.44696465*((tmean - 10.128868063) / 4.820305195) + -0.40362010*((prcpTempCorr - -0.120168217) / 0.410373104) + -0.38780455*((isothermality - 38.131295504) / 5.017482043) + -0.18796883*((annWetDegDays - 1764.581754742) / 1160.387887503) +  0.05532026*((prcp_seasonality_anom - -0.024139995) / 0.116006989)  +  0.11808213*((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.11221305*((annWetDegDays_anom - 0.01940939) / 0.210157273) + -0.03980364*I(((prcp_seasonality - 0.922874288) / 0.245115393)^2) + -0.33614836*I(((isothermality - 38.131295504) / 5.017482043)^2) + -0.03789658*I(((isothermality_anom - 0.504344509) / 1.294064496) ^2) + -0.05062253*I(((sand - 47.700975096) / 16.735018944)^2) + -0.07158871*I(((AWHC - 13.675056673) / 5.155918864)^2) +  0.28768848*((isothermality - 38.131295504) / 5.017482043):((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.51370522*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) +  0.12544456*((sand - 47.700975096) / 16.735018944):((AWHC - 13.675056673) / 5.155918864) +  0.16612760*((sand - 47.700975096) / 16.735018944):((coarse - 12.778661958) / 11.312037701) +  0.71815988*((prcpTempCorr - -0.120168217) / 0.410373104):prcp) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_CONUS_C3_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = oneSELambdaMod_CONUS_C3)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_C3_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = oneSELambdaMod_CONUS_C3)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_C3_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
modelObject = oneSELambdaMod_CONUS_C3)

C4 as proportion of total herbaceous, CONUS-wide - best lambda model

Read in the objects

# read in model objects (is the trim anomaly version)
 oneSELambdaMod_CONUS_C4 <- readRDS("./models/betaLASSO/C4GramCover_prop_CONUS_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")

ModelSpec_oneSELambdaMod_CONUS_C4 <- getModelStatement(coefficientTable = CONUS_c4_trimAnoms,
                                                    modelName <- "coefficientValue_1seLambda", 
                                                    responseVar <- "c4 cover percentage")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_oneSELambdaMod_CONUS_C4$scaledInputVars_ModelStatement)
## [1] "c4 cover percentage~ exp(-2.152686603 +  0.423638243*tmean +  1.409573134*prcpTempCorr +  0.904982906*isothermality + -0.005612865*prcpTempCorr:isothermality) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_oneSELambdaMod_CONUS_C4$unscaledInputVars_scaledModelStatement)
## [1] "c4 cover percentage~ exp(-2.152686603 +  0.423638243*((tmean - 10.128868063) / 4.820305195) +  1.409573134*((prcpTempCorr - -0.120168217) / 0.410373104) +  0.904982906*((isothermality - 38.131295504) / 5.017482043) + -0.005612865*((prcpTempCorr - -0.120168217) / 0.410373104):isothermality) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_CONUS_C4_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = oneSELambdaMod_CONUS_C4)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_C4_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = oneSELambdaMod_CONUS_C4)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_C4_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
modelObject = oneSELambdaMod_CONUS_C4)

forb as proportion of total herbaceous, CONUS-wide - best lambda model

Read in the objects

# read in model objects (is the trim anomaly version)
 oneSELambdaMod_CONUS_forb <- readRDS("./models/betaLASSO/ForbCover_prop_CONUS_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")

ModelSpec_oneSELambdaMod_CONUS_forb <- getModelStatement(coefficientTable = CONUS_forb_trimAnoms,
                                                    modelName <- "coefficientValue_1seLambda", 
                                                    responseVar <- "forb cover percentage")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_oneSELambdaMod_CONUS_forb$scaledInputVars_ModelStatement)
## [1] "forb cover percentage~ exp(-0.612615574 +  0.094292804*tmean +  0.631412160*prcp + -0.091101568*prcp_seasonality + -0.061591477*prcpTempCorr + -0.080733465*isothermality +  0.064932495*sand +  0.119108258*coarse +  0.012753143*AWHC + -0.059072555*prcp_seasonality_anom +  0.049222076*annWetDegDays_anom +  0.102663854*I(tmean^2) +  0.030196097*I(prcp_seasonality^2) +  0.010753776*I(isothermality^2) +  0.014883618*I(prcp_seasonality_anom^2) +  0.003575447*I(isothermality_anom^2) +  0.012683956*I(annWetDegDays_anom^2) +  0.000833123*I(sand^2) + -0.022685978*I(AWHC^2) + -0.052659007*prcpTempCorr:annWetDegDays + -0.238636236*tmean:annWetDegDays + -0.011920028*isothermality:annWetDegDays_anom +  0.025095543*isothermality:isothermality_anom +  0.018357908*prcp:isothermality + -0.069730992*prcpTempCorr:isothermality +  0.067141822*tmean:isothermality +  0.049533582*prcp:isothermality_anom +  0.030224163*prcp_seasonality_anom:isothermality_anom +  0.026984979*prcpTempCorr:isothermality_anom +  0.030121480*prcpTempCorr_anom:isothermality_anom + -0.042328089*tmean:isothermality_anom + -0.084548629*prcp:prcp_seasonality +  0.000501854*prcp_seasonality:prcpTempCorr_anom + -0.033668119*prcpTempCorr:prcp_seasonality_anom +  0.018981182*prcp_seasonality_anom:prcpTempCorr_anom + -0.016596864*tmean:prcp_seasonality_anom +  0.070687900*tmean:prcpTempCorr +  0.035475842*tmean:prcpTempCorr_anom + -0.145717807*sand:AWHC + -0.090887100*sand:coarse +  0.035666966*annWetDegDays_anom:prcpTempCorr_anom) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_oneSELambdaMod_CONUS_forb$unscaledInputVars_scaledModelStatement)
## [1] "forb cover percentage~ exp(-0.612615574 +  0.094292804*((tmean - 10.128868063) / 4.820305195) +  0.631412160*((prcp - 613.807482136) / 502.16616755) + -0.091101568*((prcp_seasonality - 0.922874288) / 0.245115393) + -0.061591477*((prcpTempCorr - -0.120168217) / 0.410373104) + -0.080733465*((isothermality - 38.131295504) / 5.017482043) +  0.064932495*((sand - 47.700975096) / 16.735018944) +  0.119108258*((coarse - 12.778661958) / 11.312037701) +  0.012753143*((AWHC - 13.675056673) / 5.155918864) + -0.059072555*((prcp_seasonality_anom - -0.024139995) / 0.116006989)  +  0.049222076*((annWetDegDays_anom - 0.01940939) / 0.210157273) +  0.102663854*I(((tmean - 10.128868063) / 4.820305195)^2) +  0.030196097*I(((prcp_seasonality - 0.922874288) / 0.245115393)^2) +  0.010753776*I(((isothermality - 38.131295504) / 5.017482043)^2) +  0.014883618*I(((prcp_seasonality_anom - -0.024139995) / 0.116006989) ^2) +  0.003575447*I(((isothermality_anom - 0.504344509) / 1.294064496) ^2) +  0.012683956*I(((annWetDegDays_anom - 0.01940939) / 0.210157273)^2) +  0.000833123*I(((sand - 47.700975096) / 16.735018944)^2) + -0.022685978*I(((AWHC - 13.675056673) / 5.155918864)^2) + -0.052659007*((prcpTempCorr - -0.120168217) / 0.410373104):((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.238636236*((tmean - 10.128868063) / 4.820305195):((annWetDegDays - 1764.581754742) / 1160.387887503) + -0.011920028*((isothermality - 38.131295504) / 5.017482043):((annWetDegDays_anom - 0.01940939) / 0.210157273) +  0.025095543*((isothermality - 38.131295504) / 5.017482043):((isothermality_anom - 0.504344509) / 1.294064496)  +  0.018357908*((prcp - 613.807482136) / 502.16616755):((isothermality - 38.131295504) / 5.017482043) + -0.069730992*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) +  0.067141822*((tmean - 10.128868063) / 4.820305195):((isothermality - 38.131295504) / 5.017482043) +  0.049533582*((prcp - 613.807482136) / 502.16616755):((isothermality_anom - 0.504344509) / 1.294064496)  +  0.030224163*((prcp_seasonality_anom - -0.024139995) / 0.116006989) :((isothermality_anom - 0.504344509) / 1.294064496)  +  0.026984979*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality_anom - 0.504344509) / 1.294064496)  +  0.030121480*((prcpTempCorr_anom - 0.00832419) / 0.119050826):((isothermality_anom - 0.504344509) / 1.294064496)  + -0.042328089*((tmean - 10.128868063) / 4.820305195):((isothermality_anom - 0.504344509) / 1.294064496)  + -0.084548629*((prcp - 613.807482136) / 502.16616755):((prcp_seasonality - 0.922874288) / 0.245115393) +  0.000501854*((prcp_seasonality - 0.922874288) / 0.245115393):((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.033668119*((prcpTempCorr - -0.120168217) / 0.410373104):((prcp_seasonality_anom - -0.024139995) / 0.116006989)  +  0.018981182*((prcp_seasonality_anom - -0.024139995) / 0.116006989) :((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.016596864*((tmean - 10.128868063) / 4.820305195):((prcp_seasonality_anom - -0.024139995) / 0.116006989)  +  0.070687900*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr - -0.120168217) / 0.410373104) +  0.035475842*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.145717807*((sand - 47.700975096) / 16.735018944):((AWHC - 13.675056673) / 5.155918864) + -0.090887100*((sand - 47.700975096) / 16.735018944):((coarse - 12.778661958) / 11.312037701) +  0.035666966*((annWetDegDays_anom - 0.01940939) / 0.210157273):((prcpTempCorr_anom - 0.00832419) / 0.119050826)) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_CONUS_forb_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = oneSELambdaMod_CONUS_forb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_forb_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = oneSELambdaMod_CONUS_forb)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_CONUS_forb_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
modelObject = oneSELambdaMod_CONUS_forb)

needle-leaved tree as proportion of total tree, forest - best lambda model

Read in the objects

# read in model objects (is the trim anomaly version)
 bestLambdaMod_forest_needleLeavedTree <- readRDS("./models/betaLASSO/ConifTreeCover_prop_forest_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")

ModelSpec_bestLambdaMod_forest_needleLeavedTree <- getModelStatement(coefficientTable = forest_needleLeavedTree_trimAnoms,
                                                    modelName <- "coefficientValue_bestLambda", 
                                                    responseVar <- "needleLeavedTree cover percentage")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_bestLambdaMod_forest_needleLeavedTree$scaledInputVars_ModelStatement)
## [1] "needleLeavedTree cover percentage~ exp( 1.37111313 + -0.17935873*tmean + -0.49763469*prcp_dry +  0.40113711*sand +  0.37360661*carbon + -0.34582196*AWHC +  0.05286743*I(isothermality^2) +  0.37641491*prcpTempCorr:isothermality + -0.10304070*isothermality:prcpTempCorr_anom +  0.08187013*prcp:isothermality_anom + -0.11696478*prcp_dry:prcpTempCorr +  0.09370766*tmean:prcp_dry +  0.42568784*sand:coarse) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_bestLambdaMod_forest_needleLeavedTree$unscaledInputVars_scaledModelStatement)
## [1] "needleLeavedTree cover percentage~ exp( 1.37111313 + -0.17935873*((tmean - 10.128868063) / 4.820305195) + -0.49763469*((prcp_dry - 5.007463659) / 8.212611388) +  0.40113711*((sand - 47.700975096) / 16.735018944) +  0.37360661*((carbon - 3.67729377) / 6.403824534) + -0.34582196*((AWHC - 13.675056673) / 5.155918864) +  0.05286743*I(((isothermality - 38.131295504) / 5.017482043)^2) +  0.37641491*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) + -0.10304070*((isothermality - 38.131295504) / 5.017482043):((prcpTempCorr_anom - 0.00832419) / 0.119050826) +  0.08187013*((prcp - 613.807482136) / 502.16616755):((isothermality_anom - 0.504344509) / 1.294064496)  + -0.11696478*((prcp_dry - 5.007463659) / 8.212611388):((prcpTempCorr - -0.120168217) / 0.410373104) +  0.09370766*((tmean - 10.128868063) / 4.820305195):((prcp_dry - 5.007463659) / 8.212611388) +  0.42568784*((sand - 47.700975096) / 16.735018944):((coarse - 12.778661958) / 11.312037701)) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_forest_needleLeavedTree_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = bestLambdaMod_forest_needleLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_forest_needleLeavedTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = bestLambdaMod_forest_needleLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_forest_needleLeavedTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
modelObject = bestLambdaMod_forest_needleLeavedTree)

needle-leaved tree as proportion of total tree, grass/shrub - best lambda model

Read in the objects

# read in model objects (is the trim anomaly version)
 bestLambdaMod_grassShrub_needleLeavedTree <- readRDS("./models/betaLASSO/ConifTreeCover_prop_shrubGrass_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")

ModelSpec_bestLambdaMod_grassShrub_needleLeavedTree <- getModelStatement(coefficientTable = grassShrub_needleLeavedTree_trimAnoms,
                                                    modelName <- "coefficientValue_bestLambda", 
                                                    responseVar <- "needleLeavedTree cover percentage")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_bestLambdaMod_grassShrub_needleLeavedTree$scaledInputVars_ModelStatement)
## [1] "needleLeavedTree cover percentage~ exp( 2.445095554 + -0.456318178*tmean + -1.549364543*prcp + -0.418685632*AWHC + -0.991719622*I(tmean^2) + -0.282668471*I(prcpTempCorr^2) + -0.007165025*I(isothermality^2) +  0.018801377*I(prcpTempCorr_anom^2) + -0.074950890*I(AWHC^2) + -0.720484757*tmean:isothermality + -0.500578960*tmean:prcpTempCorr +  0.234281518*AWHC:coarse) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_bestLambdaMod_grassShrub_needleLeavedTree$unscaledInputVars_scaledModelStatement)
## [1] "needleLeavedTree cover percentage~ exp( 2.445095554 + -0.456318178*((tmean - 10.128868063) / 4.820305195) + -1.549364543*((prcp - 613.807482136) / 502.16616755) + -0.418685632*((AWHC - 13.675056673) / 5.155918864) + -0.991719622*I(((tmean - 10.128868063) / 4.820305195)^2) + -0.282668471*I(((prcpTempCorr - -0.120168217) / 0.410373104)^2) + -0.007165025*I(((isothermality - 38.131295504) / 5.017482043)^2) +  0.018801377*I(((prcpTempCorr_anom - 0.00832419) / 0.119050826)^2) + -0.074950890*I(((AWHC - 13.675056673) / 5.155918864)^2) + -0.720484757*((tmean - 10.128868063) / 4.820305195):((isothermality - 38.131295504) / 5.017482043) + -0.500578960*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr - -0.120168217) / 0.410373104) +  0.234281518*((AWHC - 13.675056673) / 5.155918864):((coarse - 12.778661958) / 11.312037701)) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_grassShrub_needleLeavedTree_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = bestLambdaMod_grassShrub_needleLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_grassShrub_needleLeavedTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = bestLambdaMod_grassShrub_needleLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_grassShrub_needleLeavedTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
modelObject = bestLambdaMod_grassShrub_needleLeavedTree)

broad-leaved tree as proportion of total tree, forest - best lambda model

Read in the objects

# read in model objects (is the trim anomaly version)
 bestLambdaMod_forest_broadLeavedTree <- readRDS("./models/betaLASSO/AngioTreeCover_prop_forest_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")

ModelSpec_bestLambdaMod_forest_broadLeavedTree <- getModelStatement(coefficientTable = forest_broadLeavedTree_trimAnoms,
                                                    modelName <- "coefficientValue_bestLambda", 
                                                    responseVar <- "broadLeavedTree cover percentage")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_bestLambdaMod_forest_broadLeavedTree$scaledInputVars_ModelStatement)
## [1] "broadLeavedTree cover percentage~ exp(-1.04095920 +  0.17366458*tmean +  0.46029844*prcp_dry +  0.15397199*prcpTempCorr + -0.40824352*sand + -0.39133812*carbon +  0.33586513*AWHC + -0.11018400*prcpTempCorr_anom + -0.06898374*I(isothermality^2) + -0.36392846*prcpTempCorr:isothermality + -0.09700734*prcp:isothermality_anom +  0.08258717*prcp_dry:prcpTempCorr + -0.12349491*tmean:prcp_dry + -0.42561043*sand:coarse) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_bestLambdaMod_forest_broadLeavedTree$unscaledInputVars_scaledModelStatement)
## [1] "broadLeavedTree cover percentage~ exp(-1.04095920 +  0.17366458*((tmean - 10.128868063) / 4.820305195) +  0.46029844*((prcp_dry - 5.007463659) / 8.212611388) +  0.15397199*((prcpTempCorr - -0.120168217) / 0.410373104) + -0.40824352*((sand - 47.700975096) / 16.735018944) + -0.39133812*((carbon - 3.67729377) / 6.403824534) +  0.33586513*((AWHC - 13.675056673) / 5.155918864) + -0.11018400*((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.06898374*I(((isothermality - 38.131295504) / 5.017482043)^2) + -0.36392846*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) + -0.09700734*((prcp - 613.807482136) / 502.16616755):((isothermality_anom - 0.504344509) / 1.294064496)  +  0.08258717*((prcp_dry - 5.007463659) / 8.212611388):((prcpTempCorr - -0.120168217) / 0.410373104) + -0.12349491*((tmean - 10.128868063) / 4.820305195):((prcp_dry - 5.007463659) / 8.212611388) + -0.42561043*((sand - 47.700975096) / 16.735018944):((coarse - 12.778661958) / 11.312037701)) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_forest_broadLeavedTree_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = bestLambdaMod_forest_broadLeavedTree)

# predict with best SE lambda model w/ forecasted climate data
bestLambda_forest_broadLeavedTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = bestLambdaMod_forest_broadLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_forest_broadLeavedTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
modelObject = bestLambdaMod_forest_broadLeavedTree)

broad-leaved tree as proportion of total tree, grassShrub - best lambda model

Read in the objects

# read in model objects (is the trim anomaly version)
 bestLambdaMod_grassShrub_broadLeavedTree <- readRDS("./models/betaLASSO/AngioTreeCover_prop_shrubGrass_noTLP_FALSE_removeAnomaliesFALSE_trimAnom_bestLambdaGLM.rds")

ModelSpec_bestLambdaMod_grassShrub_broadLeavedTree <- getModelStatement(coefficientTable = grassShrub_broadLeavedTree_trimAnoms,
                                                    modelName <- "coefficientValue_bestLambda", 
                                                    responseVar <- "broadLeavedTree cover percentage")

This is the best Lambda model equation if the inputs are scaled:

(ModelSpec_bestLambdaMod_grassShrub_broadLeavedTree$scaledInputVars_ModelStatement)
## [1] "broadLeavedTree cover percentage~ exp(-1.807187155 +  0.652460140*tmean +  0.979557507*prcp + -0.176042723*prcpTempCorr +  0.081019085*sand +  0.391363994*coarse +  0.562437594*AWHC + -0.257519658*prcp_seasonality_anom +  0.738816644*I(tmean^2) +  0.435985654*I(prcpTempCorr^2) +  0.054837095*I(isothermality_anom^2) + -0.007055441*I(coarse^2) +  0.103295026*I(AWHC^2) +  0.031564850*isothermality:isothermality_anom + -0.223847233*prcpTempCorr:isothermality +  0.629262630*tmean:isothermality +  0.098746055*prcp_seasonality_anom:isothermality_anom +  0.152657720*prcpTempCorr:isothermality_anom +  0.170722905*prcp_seasonality:prcpTempCorr_anom +  0.115774462*tmean:prcp_seasonality_anom +  0.470988259*tmean:prcpTempCorr +  0.053978203*tmean:prcpTempCorr_anom + -0.191502134*coarse:AWHC + -0.352779396*sand:AWHC + -0.379793154*sand:coarse) - 2"

This is the best Lambda model equation if the inputs are not scaled:

(ModelSpec_bestLambdaMod_grassShrub_broadLeavedTree$unscaledInputVars_scaledModelStatement)
## [1] "broadLeavedTree cover percentage~ exp(-1.807187155 +  0.652460140*((tmean - 10.128868063) / 4.820305195) +  0.979557507*((prcp - 613.807482136) / 502.16616755) + -0.176042723*((prcpTempCorr - -0.120168217) / 0.410373104) +  0.081019085*((sand - 47.700975096) / 16.735018944) +  0.391363994*((coarse - 12.778661958) / 11.312037701) +  0.562437594*((AWHC - 13.675056673) / 5.155918864) + -0.257519658*((prcp_seasonality_anom - -0.024139995) / 0.116006989)  +  0.738816644*I(((tmean - 10.128868063) / 4.820305195)^2) +  0.435985654*I(((prcpTempCorr - -0.120168217) / 0.410373104)^2) +  0.054837095*I(((isothermality_anom - 0.504344509) / 1.294064496) ^2) + -0.007055441*I(((coarse - 12.778661958) / 11.312037701)^2) +  0.103295026*I(((AWHC - 13.675056673) / 5.155918864)^2) +  0.031564850*((isothermality - 38.131295504) / 5.017482043):((isothermality_anom - 0.504344509) / 1.294064496)  + -0.223847233*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality - 38.131295504) / 5.017482043) +  0.629262630*((tmean - 10.128868063) / 4.820305195):((isothermality - 38.131295504) / 5.017482043) +  0.098746055*((prcp_seasonality_anom - -0.024139995) / 0.116006989) :((isothermality_anom - 0.504344509) / 1.294064496)  +  0.152657720*((prcpTempCorr - -0.120168217) / 0.410373104):((isothermality_anom - 0.504344509) / 1.294064496)  +  0.170722905*((prcp_seasonality - 0.922874288) / 0.245115393):((prcpTempCorr_anom - 0.00832419) / 0.119050826) +  0.115774462*((tmean - 10.128868063) / 4.820305195):((prcp_seasonality_anom - -0.024139995) / 0.116006989)  +  0.470988259*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr - -0.120168217) / 0.410373104) +  0.053978203*((tmean - 10.128868063) / 4.820305195):((prcpTempCorr_anom - 0.00832419) / 0.119050826) + -0.191502134*((coarse - 12.778661958) / 11.312037701):((AWHC - 13.675056673) / 5.155918864) + -0.352779396*((sand - 47.700975096) / 16.735018944):((AWHC - 13.675056673) / 5.155918864) + -0.379793154*((sand - 47.700975096) / 16.735018944):((coarse - 12.778661958) / 11.312037701)) - 2"

Predict

# predict w/ best SE lambda model
bestLambda_grassShrub_broadLeavedTree_predict <- makePredictions(predictionDF = climDatPred, 
                                                           modelObject = bestLambdaMod_grassShrub_broadLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_grassShrub_broadLeavedTree_predictFuture_1 <- makePredictions(predictionDF = forecastClimSoilsDatPred_1, 
                                                           modelObject = bestLambdaMod_grassShrub_broadLeavedTree)
# predict with best SE lambda model w/ forecasted climate data
bestLambda_grassShrub_broadLeavedTree_predictFuture_2 <- makePredictions(predictionDF = forecastClimSoilsDatPred_2, 
modelObject = bestLambdaMod_grassShrub_broadLeavedTree)

Combine the level 2 cover variables (combine and scale to sum to 100 - for both total herbaceous and total tree cover)

rm(climDatPred)
gc() 
##             used   (Mb) gc trigger   (Mb) limit (Mb)   max used    (Mb)
## Ncells   3540080  189.1    7541957  402.8         NA    7541957   402.8
## Vcells 773037430 5897.9 1245276334 9500.8      65536 2511826459 19163.8
# for contemporary data
names(bestLambda_CONUS_C3_predict)[57] <- "C3_percentage_pred"
names(bestLambda_CONUS_C4_predict)[57] <- "C4_percentage_pred"
names(bestLambda_CONUS_forb_predict)[57] <- "forb_percentage_pred"
names(bestLambda_grassShrub_broadLeavedTree_predict)[57] <- "broadLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_broadLeavedTree_predict)[57] <- "broadLeavedTree_forest_percentage_pred"
names(bestLambda_grassShrub_needleLeavedTree_predict)[57] <- "needleLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_needleLeavedTree_predict)[57] <- "needleLeavedTree_forest_percentage_pred"

level2_cover_preds_contemp <- bestLambda_CONUS_C3_predict  %>% 
  cbind(bestLambda_CONUS_C4_predict %>% select(C4_percentage_pred)) %>% 
  cbind(bestLambda_CONUS_forb_predict %>% select(forb_percentage_pred)) %>% 
  cbind(bestLambda_grassShrub_broadLeavedTree_predict %>% select(broadLeavedTree_grassShrub_percentage_pred)) %>% 
  cbind(bestLambda_forest_broadLeavedTree_predict %>% select(broadLeavedTree_forest_percentage_pred)) %>% 
  cbind(bestLambda_grassShrub_needleLeavedTree_predict %>% select(needleLeavedTree_grassShrub_percentage_pred)) %>% 
  cbind(bestLambda_forest_needleLeavedTree_predict %>% select(needleLeavedTree_forest_percentage_pred)) 

level2_cover_preds_contemp <- level2_cover_preds_contemp %>% 
  mutate("sumFromModels_totalHerbaceousCover" = C3_percentage_pred +  C4_percentage_pred + forb_percentage_pred, 
         "sumFromModels_forest_totalTreeCover" = broadLeavedTree_forest_percentage_pred + needleLeavedTree_forest_percentage_pred,  
         "sumFromModels_grassShrub_totalTreeCover" = broadLeavedTree_grassShrub_percentage_pred + needleLeavedTree_grassShrub_percentage_pred) %>% 
  mutate(C3_percentage_scaled = (C3_percentage_pred/sumFromModels_totalHerbaceousCover),
         C4_percentage_scaled = (C4_percentage_pred/sumFromModels_totalHerbaceousCover),
         forb_percentage_scaled = (forb_percentage_pred/sumFromModels_totalHerbaceousCover),
         broadLeavedTree_forest_percentage_scaled = (broadLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
         needleLeavedTree_forest_percentage_scaled = (needleLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
         broadLeavedTree_grassShrub_percentage_scaled = (broadLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover),
         needleLeavedTree_grassShrub_percentage_scaled = (needleLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover))
  
# for future model 1
names(bestLambda_CONUS_C3_predictFuture_1)[55] <- "C3_percentage_pred"
names(bestLambda_CONUS_C4_predictFuture_1)[55] <- "C4_percentage_pred"
names(bestLambda_CONUS_forb_predictFuture_1)[55] <- "forb_percentage_pred"
names(bestLambda_grassShrub_broadLeavedTree_predictFuture_1)[55] <- "broadLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_broadLeavedTree_predictFuture_1)[55] <- "broadLeavedTree_forest_percentage_pred"
names(bestLambda_grassShrub_needleLeavedTree_predictFuture_1)[55] <- "needleLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_needleLeavedTree_predictFuture_1)[55] <- "needleLeavedTree_forest_percentage_pred"

level2_cover_preds_future1 <- bestLambda_CONUS_C3_predictFuture_1 %>% 
  cbind(bestLambda_CONUS_C4_predictFuture_1 %>% select(C4_percentage_pred)) %>% 
  cbind(bestLambda_CONUS_forb_predictFuture_1 %>% select(forb_percentage_pred)) %>% 
  cbind(bestLambda_grassShrub_broadLeavedTree_predictFuture_1%>% select(broadLeavedTree_grassShrub_percentage_pred)) %>% 
  cbind(bestLambda_forest_broadLeavedTree_predictFuture_1%>% select(broadLeavedTree_forest_percentage_pred)) %>% 
  cbind(bestLambda_grassShrub_needleLeavedTree_predictFuture_1%>% select(needleLeavedTree_grassShrub_percentage_pred)) %>% 
  cbind(bestLambda_forest_needleLeavedTree_predictFuture_1%>% select(needleLeavedTree_forest_percentage_pred)) 

level2_cover_preds_future1 <- level2_cover_preds_future1 %>% 
  mutate("sumFromModels_totalHerbaceousCover" = C3_percentage_pred +  C4_percentage_pred + forb_percentage_pred, 
         "sumFromModels_forest_totalTreeCover" = broadLeavedTree_forest_percentage_pred + needleLeavedTree_forest_percentage_pred,  
         "sumFromModels_grassShrub_totalTreeCover" = broadLeavedTree_grassShrub_percentage_pred + needleLeavedTree_grassShrub_percentage_pred) %>% 
  mutate(C3_percentage_scaled = (C3_percentage_pred/sumFromModels_totalHerbaceousCover),
         C4_percentage_scaled = (C4_percentage_pred/sumFromModels_totalHerbaceousCover),
         forb_percentage_scaled = (forb_percentage_pred/sumFromModels_totalHerbaceousCover),
         broadLeavedTree_forest_percentage_scaled = (broadLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
         needleLeavedTree_forest_percentage_scaled = (needleLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
         broadLeavedTree_grassShrub_percentage_scaled = (broadLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover),
         needleLeavedTree_grassShrub_percentage_scaled = (needleLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover))
  
# for model 2
names(bestLambda_CONUS_C3_predictFuture_2)[55] <- "C3_percentage_pred"
names(bestLambda_CONUS_C4_predictFuture_2)[55] <- "C4_percentage_pred"
names(bestLambda_CONUS_forb_predictFuture_2)[55] <- "forb_percentage_pred"
names(bestLambda_grassShrub_broadLeavedTree_predictFuture_2)[55] <- "broadLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_broadLeavedTree_predictFuture_2)[55] <- "broadLeavedTree_forest_percentage_pred"
names(bestLambda_grassShrub_needleLeavedTree_predictFuture_2)[55] <- "needleLeavedTree_grassShrub_percentage_pred"
names(bestLambda_forest_needleLeavedTree_predictFuture_2)[55] <- "needleLeavedTree_forest_percentage_pred"

level2_cover_preds_future2 <- bestLambda_CONUS_C3_predictFuture_2 %>% 
  cbind(bestLambda_CONUS_C4_predictFuture_2 %>% select(C4_percentage_pred)) %>% 
  cbind(bestLambda_CONUS_forb_predictFuture_2 %>% select(forb_percentage_pred)) %>% 
  cbind(bestLambda_grassShrub_broadLeavedTree_predictFuture_2%>% select(broadLeavedTree_grassShrub_percentage_pred)) %>% 
  cbind(bestLambda_forest_broadLeavedTree_predictFuture_2%>% select(broadLeavedTree_forest_percentage_pred)) %>% 
  cbind(bestLambda_grassShrub_needleLeavedTree_predictFuture_2%>% select(needleLeavedTree_grassShrub_percentage_pred)) %>% 
  cbind(bestLambda_forest_needleLeavedTree_predictFuture_2%>% select(needleLeavedTree_forest_percentage_pred)) 

level2_cover_preds_future2 <- level2_cover_preds_future2 %>% 
  mutate("sumFromModels_totalHerbaceousCover" = C3_percentage_pred +  C4_percentage_pred + forb_percentage_pred, 
         "sumFromModels_forest_totalTreeCover" = broadLeavedTree_forest_percentage_pred + needleLeavedTree_forest_percentage_pred,  
         "sumFromModels_grassShrub_totalTreeCover" = broadLeavedTree_grassShrub_percentage_pred + needleLeavedTree_grassShrub_percentage_pred) %>% 
  mutate(C3_percentage_scaled = (C3_percentage_pred/sumFromModels_totalHerbaceousCover),
         C4_percentage_scaled = (C4_percentage_pred/sumFromModels_totalHerbaceousCover),
         forb_percentage_scaled = (forb_percentage_pred/sumFromModels_totalHerbaceousCover),
         broadLeavedTree_forest_percentage_scaled = (broadLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
         needleLeavedTree_forest_percentage_scaled = (needleLeavedTree_forest_percentage_pred/sumFromModels_forest_totalTreeCover),
         broadLeavedTree_grassShrub_percentage_scaled = (broadLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover),
         needleLeavedTree_grassShrub_percentage_scaled = (needleLeavedTree_grassShrub_percentage_pred/sumFromModels_grassShrub_totalTreeCover))

visualize the scaled level 2 predictions

i.e. the following predictions are the proportion of the relevant level 1 group (total herbaceous or total tree) that is composed of each level 2 functional group, after those groups have been ‘scaled’ to sum to 1 (e.g. proportion of total herbaceous that is C3, C4, or forb sums to 1)

C3 cover

# predict w/ best model
plotObs <- level2_cover_preds_contemp %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "C3_percentage_scaled", 
                   fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "C3_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "C3_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_C3_proportion <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "C3GramCover_prop", 
                   fun = mean, na.rm = TRUE)

plotObservations_C3_proportion_2 <- plotObservations_C3_proportion %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C3GramCover_prop in the 
                    CONUS ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C3GramCover_prop in the 
                    CONUS ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C3GramCover_prop in the 
                    CONUS ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_CONUS_C3 <- ggplot() +
  geom_spatraster(data = plotObservations_C3_proportion_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total herbaceous that is C3GramCover")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(level2_cover_preds_contemp) + 
  geom_density(aes(C3_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(C3_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(C3_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(C3GramCover_prop), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_C3_proportion_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      CONUS-wide model of C3GramCover_prop"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for 
                      CONUS-wide model of C3GramCover_prop; (models with 
                      predictions with modeled climate data from model BNU-ESM 
                      model - models with predictions from 
                      contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for
  CONUS-wide model of C3GramCover_prop; 
  (models with predictions with modeled 
  climate data from model IPSL-CM5A-MR 
  model- models with predictions from 
  contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_CONUS_C3, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of C3GramCover_prop with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

C4 cover

# predict w/ best model
plotObs <- level2_cover_preds_contemp %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "C4_percentage_scaled", 
                   fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "C4_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "C4_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_C4_proportion <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "C4GramCover_prop", 
                   fun = mean, na.rm = TRUE)

plotObservations_C4_proportion_2 <- plotObservations_C4_proportion %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C4GramCover_prop in the 
                    CONUS ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C4GramCover_prop in the 
                    CONUS ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of C4GramCover_prop in the 
                    CONUS ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_CONUS_C4 <- ggplot() +
  geom_spatraster(data = plotObservations_C4_proportion_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total herbaceous that is C4GramCover")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(level2_cover_preds_contemp) + 
  geom_density(aes(C4_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(C4_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(C4_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(C4GramCover_prop), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_C4_proportion_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      CONUS-wide model of C4GramCover_prop"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for 
                      CONUS-wide model of C4GramCover_prop; (models with 
                      predictions with modeled climate data from model BNU-ESM 
                      model - models with predictions from 
                      contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for
  CONUS-wide model of C4GramCover_prop; 
  (models with predictions with modeled 
  climate data from model IPSL-CM5A-MR 
  model- models with predictions from 
  contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_CONUS_C4, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of C4GramCover_prop with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

forb cover

# predict w/ best model
plotObs <- level2_cover_preds_contemp %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "forb_percentage_scaled", 
                   fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "forb_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "forb_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_forb_proportion <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "ForbCover_prop", 
                   fun = mean, na.rm = TRUE)

plotObservations_forb_proportion_2 <- plotObservations_forb_proportion %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of ForbCover_prop in the 
                    CONUS ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of ForbCover_prop in the 
                    CONUS ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of ForbCover_prop in the 
                    CONUS ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_CONUS_forb <- ggplot() +
  geom_spatraster(data = plotObservations_forb_proportion_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total herbaceous that is Forbs")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(level2_cover_preds_contemp) + 
  geom_density(aes(forb_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(forb_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(forb_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(ForbCover_prop), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_forb_proportion_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      CONUS-wide model of forb cover"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for 
                      CONUS-wide model of forb cover; (models with 
                      predictions with modeled climate data from model BNU-ESM 
                      model - models with predictions from 
                      contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for
  CONUS-wide model of forb cover; 
  (models with predictions with modeled 
  climate data from model IPSL-CM5A-MR 
  model- models with predictions from 
  contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_CONUS_forb, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of forb proportion with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

broad-leaved tree cover – forest

# predict w/ best model
plotObs <- level2_cover_preds_contemp %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "broadLeavedTree_forest_percentage_scaled", 
                   fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "broadLeavedTree_forest_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "broadLeavedTree_forest_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_broadLeaved_forest_proportion <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "AngioTreeCover_prop", 
                   fun = mean, na.rm = TRUE)

plotObservations_broadLeaved_forest_proportion_2 <- plotObservations_broadLeaved_forest_proportion %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the 
                    forest ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the 
                    forest ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the 
                    forest ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_forest_broadLeavedTree <- ggplot() +
  geom_spatraster(data = plotObservations_broadLeaved_forest_proportion_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total tree cover that is Broad-leaved tree")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(level2_cover_preds_contemp) + 
  geom_density(aes(broadLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(broadLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(broadLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(AngioTreeCover_prop), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_broadLeaved_forest_proportion_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                     forest model of broad-leaved tree cover"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for 
                      forest model of broad-leaved tree covver; (models with 
                      predictions with modeled climate data from model BNU-ESM 
                      model - models with predictions from 
                      contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for
  forest model of broad-leaved tree covver; 
  (models with predictions with modeled 
  climate data from model IPSL-CM5A-MR 
  model- models with predictions from 
  contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_forest_broadLeavedTree, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of broadLeavedTree proportion in forests with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

needle-leaved tree cover – forest

# predict w/ best model
plotObs <- level2_cover_preds_contemp %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "needleLeavedTree_forest_percentage_scaled", 
                   fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "needleLeavedTree_forest_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "needleLeavedTree_forest_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_needleLeaved_proportion <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "ConifTreeCover_prop", 
                   fun = mean, na.rm = TRUE)

plotObservations_needleLeaved_proportion_2 <- plotObservations_needleLeaved_proportion %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the 
                    forest ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the 
                    forest ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the 
                    forest ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_CONUS_needleLeavedTree <- ggplot() +
  geom_spatraster(data = plotObservations_needleLeaved_proportion) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total tree cover that is needle-leaved")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(level2_cover_preds_contemp) + 
  geom_density(aes(needleLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(needleLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(needleLeavedTree_forest_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(ConifTreeCover_prop), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_needleLeaved_proportion_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      forest model of needle-leaved tree cover"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for 
                      forest model of needle-leaved tree covver; (models with 
                      predictions with modeled climate data from model BNU-ESM 
                      model - models with predictions from 
                      contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for
  forest model of needle-leaved tree cover; 
  (models with predictions with modeled 
  climate data from model IPSL-CM5A-MR 
  model- models with predictions from 
  contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_CONUS_needleLeavedTree, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of needleLeavedTree proportion with Forest Model using Contemporary and Forecasted Climate Data", fig.lab.size = 20)

broad-leaved tree cover – grass/shrub

# predict w/ best model
plotObs <- level2_cover_preds_contemp %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "broadLeavedTree_grassShrub_percentage_scaled", 
                   fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "broadLeavedTree_grassShrub_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "broadLeavedTree_grassShrub_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_broadLeaved_grassShrub_proportion <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "AngioTreeCover_prop", 
                   fun = mean, na.rm = TRUE)

plotObservations_broadLeaved_grassShrub_proportion_2 <- plotObservations_broadLeaved_grassShrub_proportion %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the 
                    grass/shrub ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the 
                    grass/shrub ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of Broad-leaved tree cover in the 
                    grass/shrub ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_grassShrub_broadLeavedTree <- ggplot() +
  geom_spatraster(data = plotObservations_broadLeaved_grassShrub_proportion_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total tree cover that is Broad-leaved tree")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(level2_cover_preds_contemp) + 
  geom_density(aes(broadLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(broadLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(broadLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(AngioTreeCover_prop), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_broadLeaved_grassShrub_proportion_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                     grass/shrub model of broad-leaved tree cover"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for 
                      grass/shrub model of broad-leaved tree covver; (models with 
                      predictions with modeled climate data from model BNU-ESM 
                      model - models with predictions from 
                      contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for
  grass/shrub model of broad-leaved tree covver; 
  (models with predictions with modeled 
  climate data from model IPSL-CM5A-MR 
  model- models with predictions from 
  contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_grassShrub_broadLeavedTree, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of broadLeavedTree proportion in grass/shrub with Contemporary and Forecasted Climate Data", fig.lab.size = 20)

needle-leaved tree cover – grass/shrub

# predict w/ best model
plotObs <- level2_cover_preds_contemp %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                   field = "needleLeavedTree_grassShrub_percentage_scaled", 
                   fun = mean, na.rm = TRUE)
# get the extent of this particular raster, and crop it accordingly

plotObs_2 <- plotObs %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

## map best SE lambda predictions for the future model #1
plotObs_bestLambdaFuture1 <- level2_cover_preds_future1 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "needleLeavedTree_grassShrub_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture1_2 <- plotObs_bestLambdaFuture1 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
## map best SE lambda predictions for the future model #2
plotObs_bestLambdaFuture2 <- level2_cover_preds_future2 %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("x", "y")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "needleLeavedTree_grassShrub_percentage_scaled", 
                   fun = mean, na.rm = TRUE)

plotObs_bestLambdaFuture2_2 <- plotObs_bestLambdaFuture2 %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )

# get plot of observations
plotObservations_needleLeaved_proportion <- modDat_1_s %>% 
         #drop_na(paste(response)) %>% 
  #slice_sample(n = 5e4) %>%
  terra::vect(geom = c("Long", "Lat")) %>% 
  terra::set.crs(crs(test_rast)) %>% 
  terra::rasterize(y = test_rast, 
                     field = "ConifTreeCover_prop", 
                   fun = mean, na.rm = TRUE)

plotObservations_needleLeaved_proportion_2 <- plotObservations_needleLeaved_proportion %>% 
  crop(ext(min(tempExt[,1]), max(tempExt[,1]),
           min(tempExt[,2]), max(tempExt[,2])) 
       )
# make figures
map <- ggplot() +
geom_spatraster(data = plotObs_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the 
                    grass/shrub ecoregion 
                    using contemporary climate data"),
      subtitle = "bestLambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future1 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture1_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the 
                    grass/shrub ecoregion
                    using modeled climate data from BNU-ESM model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_bestlambda_future2 <- ggplot() +
geom_spatraster(data = plotObs_bestLambdaFuture2_2) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Scaled Predictions of needle-leaved tree cover in the 
                    grass/shrub ecoregion
                    using modeled climate data from IPSL-CM5A-MR model"),
      subtitle = "best Lambda model") +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

map_obs_CONUS_needleLeavedTree <- ggplot() +
  geom_spatraster(data = plotObservations_needleLeaved_proportion) + 
  geom_sf(data = mapRegions, fill = NA, col = "rosybrown4", lwd = .5) +
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(plotObs_2)),fill=NA ) +
labs(title = paste0("Observations of the proportion of total tree cover that is needle-leaved")) +
  scale_fill_gradient2(low = "brown",
                       mid = "wheat" ,
                       high = "darkgreen" , 
                       midpoint = 0, limits = c(0,1),  na.value = "lightgrey") + 
  xlim(st_bbox(plotObs_2)[c(1,3)]) + 
  ylim(st_bbox(plotObs_2)[c(2,4)])

hist <- ggplot(level2_cover_preds_contemp) + 
  geom_density(aes(needleLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture1 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(needleLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_bestlambdaFuture2 <-  ggplot(level2_cover_preds_future1) + 
  geom_density(aes(needleLeavedTree_grassShrub_percentage_scaled), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ylab("frequency")

hist_obs <- ggplot(modDat_1_s) + 
  geom_density(aes(ConifTreeCover_prop), fill = "lightgrey", col = "darkgrey") + 
   xlab("Predicted Value") + 
  ggtitle("Pink = predictions within 
          the focal ecoregion") +
  ylab("frequency")

## calculate residuals for contemporary prediction
# (observed - predicted)
resids <-  plotObservations_needleLeaved_proportion_2 - plotObs_2 
map_resids_trimAnoms <- ggplot() +
geom_spatraster(data = resids) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(resids)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Resids. (obs. - pred.) from the 
                      grass/shrub model of needle-leaved tree cover"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model with contemporary climate data") +
  scale_fill_gradient2(low = "red",
                       mid = "white" ,
                       high = "blue" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(resids)[c(1,3)]) + 
  ylim(st_bbox(resids)[c(2,4)])

hist_trimAnoms_resids <-  ggplot(resids) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") + 
  geom_vline(aes(xintercept = mean(terra::values(resids$mean), na.rm = TRUE)))

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model1 <-  plotObs_bestLambdaFuture1_2 - plotObs_2 

map_deltas_model1 <- ggplot() +
geom_spatraster(data = predDeltas_model1) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model1)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for 
                      grass/shrub model of needle-leaved tree covver; (models with 
                      predictions with modeled climate data from model BNU-ESM 
                      model - models with predictions from 
                      contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model1)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model1)[c(2,4)])

hist_deltas_model1 <-  ggplot(predDeltas_model1) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

# calculate deltas from model 1(future model predictions - contemporary model predictions)
predDeltas_model2 <-  plotObs_bestLambdaFuture2_2 - plotObs_2 

map_deltas_model2 <- ggplot() +
geom_spatraster(data = predDeltas_model2) + 
  geom_sf(data=cropped_states %>% st_transform(crs = st_crs(test_rast)) %>% st_crop(st_bbox(predDeltas_model2)),fill=NA )  + 
  geom_sf(data = mapRegions, fill = NA, col = "orchid", lwd = .5) +
  labs(title = paste0("Future Climate Model Deltas for
  grass/shrub model of needle-leaved tree cover; 
  (models with predictions with modeled 
  climate data from model IPSL-CM5A-MR 
  model- models with predictions from 
  contemporary climate data)"),
     subtitle = "using predictions from the Trim Anomalies 
     bestLambda model") +
  scale_fill_gradient2(low = "orange",
                       mid = "white" ,
                       high = "purple" , 
                       midpoint = 0,   na.value = "grey20",
                       limits = c(-1,1)
                       ) + 
  xlim(st_bbox(predDeltas_model2)[c(1,3)]) + 
  ylim(st_bbox(predDeltas_model2)[c(2,4)])

hist_deltas_model2 <-  ggplot(predDeltas_model2) + 
  geom_density(aes(mean), fill = "lightgrey", col = "darkgrey") + 
  xlab("Predicted Value") + 
  ylab("frequency") 

## conglomerate figure

  ggarrange(map_obs_CONUS_needleLeavedTree, hist_obs, heights = c(3,1), ncol = 1, nrow  = 2)

  # plot model forecasts with model that does not exclude anomalies
       ggarrange(map, map_bestlambda_future1, map_bestlambda_future2,
              hist, hist_bestlambdaFuture1, hist_bestlambdaFuture2, 
            map_resids_trimAnoms, map_deltas_model1, map_deltas_model2,
            hist_trimAnoms_resids, hist_deltas_model1, hist_deltas_model2,
            heights = c(3,1), ncol = 3, nrow = 4) %>% 
  annotate_figure(fig.lab = "Model Predictions of needleLeavedTree proportion with grass/shrub Model using Contemporary and Forecasted Climate Data", fig.lab.size = 20)